From 36b0a1b039d86aea9b9684db3b8edaf09a150285 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 28 Jun 2009 17:56:41 +0000 Subject: 2009-06-28 Tobias Burnus Francois-Xavier Coudert PR fortran/34112 * symbol.c (gfc_add_ext_attribute): New function. (gfc_get_sym_tree): New argument allow_subroutine. (gfc_get_symbol,gfc_get_ha_sym_tree,gen_cptr_param,gen_fptr_param gen_shape_param,generate_isocbinding_symbol): Use it. * decl.c (find_special): New argument allow_subroutine. (add_init_expr_to_sym,add_hidden_procptr_result,attr_decl1, match_procedure_in_type,gfc_match_final_decl): Use it. (gfc_match_gcc_attributes): New function. * gfortran.texi (Mixed-Language Programming): New section "GNU Fortran Compiler Directives". * gfortran.h (ext_attr_t): New struct. (symbol_attributes): Use it. (gfc_add_ext_attribute): New prototype. (gfc_get_sym_tree): Update pototype. * expr.c (gfc_check_pointer_assign): Check whether call convention is the same. * module.c (import_iso_c_binding_module, create_int_parameter, use_iso_fortran_env_module): Update gfc_get_sym_tree call. * scanner.c (skip_gcc_attribute): New function. (skip_free_comments,skip_fixed_comments): Use it. (gfc_next_char_literal): Support !GCC$ lines. * resolve.c (check_host_association): Update gfc_get_sym_tree call. * match.c (gfc_match_sym_tree,gfc_match_call): Update gfc_get_sym_tree call. * trans-decl.c (add_attributes_to_decl): New function. (gfc_get_symbol_decl,get_proc_pointer_decl, gfc_get_extern_function_decl,build_function_decl: Use it. * match.h (gfc_match_gcc_attributes): Add prototype. * parse.c (decode_gcc_attribute): New function. (next_free,next_fixed): Support !GCC$ lines. * primary.c (match_actual_arg,check_for_implicit_index, gfc_match_rvalue,gfc_match_rvalue): Update gfc_get_sym_tree call. 2009-06-28 Tobias Burnus PR fortran/34112 * gfortran.dg/compiler-directive_1.f90: New test. * gfortran.dg/compiler-directive_2.f: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149036 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 2049fa400b1..b1d572ec231 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3186,6 +3186,32 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) rvalue->symtree->name, &rvalue->where) == FAILURE) return FAILURE; } + + /* Ensure that the calling convention is the same. As other attributes + such as DLLEXPORT may differ, one explicitly only tests for the + calling conventions. */ + if (rvalue->expr_type == EXPR_VARIABLE + && lvalue->symtree->n.sym->attr.ext_attr + != rvalue->symtree->n.sym->attr.ext_attr) + { + symbol_attribute cdecl, stdcall, fastcall; + unsigned calls; + + gfc_add_ext_attribute (&cdecl, (unsigned) EXT_ATTR_CDECL, NULL); + gfc_add_ext_attribute (&stdcall, (unsigned) EXT_ATTR_STDCALL, NULL); + gfc_add_ext_attribute (&fastcall, (unsigned) EXT_ATTR_FASTCALL, NULL); + calls = cdecl.ext_attr | stdcall.ext_attr | fastcall.ext_attr; + + if ((calls & lvalue->symtree->n.sym->attr.ext_attr) + != (calls & rvalue->symtree->n.sym->attr.ext_attr)) + { + gfc_error ("Mismatch in the procedure pointer assignment " + "at %L: mismatch in the calling convention", + &rvalue->where); + return FAILURE; + } + } + /* TODO: Enable interface check for PPCs. */ if (is_proc_ptr_comp (rvalue, NULL)) return SUCCESS; -- cgit v1.2.1 From ff70e44325c390560120b8ab5a8e0043d0403aef Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 9 Jul 2009 14:07:03 +0000 Subject: 2009-07-09 Janus Weil PR fortran/40646 * dump-parse-tree.c (show_expr): Renamed 'is_proc_ptr_comp'. * expr.c (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'. (gfc_check_pointer_assign): Renamed 'is_proc_ptr_comp'. (replace_comp,gfc_expr_replace_comp): New functions, analogous to 'replace_symbol' and 'gfc_expr_replace_symbol', just with components instead of symbols. * gfortran.h (gfc_expr_replace_comp): New prototype. (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'. * interface.c (compare_actual_formal): Renamed 'is_proc_ptr_comp'. * match.c (gfc_match_pointer_assignment): Ditto. * primary.c (gfc_match_varspec): Handle array-valued procedure pointers and procedure pointer components. Renamed 'is_proc_ptr_comp'. * resolve.c (resolve_fl_derived): Correctly handle interfaces with RESULT statement, and handle array-valued procedure pointer components. (resolve_actual_arglist,resolve_ppc_call,resolve_expr_ppc): Renamed 'is_proc_ptr_comp'. * trans-array.c (gfc_walk_function_expr): Ditto. * trans-decl.c (gfc_get_symbol_decl): Security check for presence of ns->proc_name. * trans-expr.c (gfc_conv_procedure_call): Handle array-valued procedure pointer components. Renamed 'is_proc_ptr_comp'. (conv_function_val,gfc_trans_arrayfunc_assign): Renamed 'is_proc_ptr_comp'. (gfc_get_proc_ptr_comp): Do not modify the argument 'e', but instead make a copy of it. * trans-io.c (gfc_trans_transfer): Handle array-valued procedure pointer components. 2009-07-09 Janus Weil PR fortran/40646 * gfortran.dg/proc_ptr_22.f90: New. * gfortran.dg/proc_ptr_comp_12.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149419 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 40 ++++++++++++++++++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index b1d572ec231..a8f9f6a213e 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3213,7 +3213,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } /* TODO: Enable interface check for PPCs. */ - if (is_proc_ptr_comp (rvalue, NULL)) + if (gfc_is_proc_ptr_comp (rvalue, NULL)) return SUCCESS; if ((rvalue->expr_type == EXPR_VARIABLE && !gfc_compare_interfaces (lvalue->symtree->n.sym, @@ -3558,7 +3558,7 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr) provided). */ bool -is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp) +gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp) { gfc_ref *ref; bool ppc = false; @@ -3672,3 +3672,39 @@ gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest) { gfc_traverse_expr (expr, dest, &replace_symbol, 0); } + +/* The following is analogous to 'replace_symbol', and needed for copying + interfaces for procedure pointer components. The argument 'sym' must formally + be a gfc_symbol, so that the function can be passed to gfc_traverse_expr. + However, it gets actually passed a gfc_component (i.e. the procedure pointer + component in whose formal_ns the arguments have to be). */ + +static bool +replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED) +{ + gfc_component *comp; + comp = (gfc_component *)sym; + if ((expr->expr_type == EXPR_VARIABLE + || (expr->expr_type == EXPR_FUNCTION + && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where))) + && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns) + { + gfc_symtree *stree; + gfc_namespace *ns = comp->formal_ns; + /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find + the symtree rather than create a new one (and probably fail later). */ + stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root, + expr->symtree->n.sym->name); + gcc_assert (stree); + stree->n.sym->attr = expr->symtree->n.sym->attr; + expr->symtree = stree; + } + return false; +} + +void +gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest) +{ + gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0); +} + -- cgit v1.2.1 From 5d50997a4873b2ff4acdfe03f24b81d7ada048fd Mon Sep 17 00:00:00 2001 From: janus Date: Fri, 24 Jul 2009 11:00:01 +0000 Subject: 2009-07-24 Janus Weil PR fortran/40822 * array.c (gfc_resolve_character_array_constructor): Use new function gfc_new_charlen. * decl.c (add_init_expr_to_sym,variable_decl,match_char_spec, gfc_match_implicit): Ditto. * expr.c (gfc_simplify_expr): Ditto. * gfortran.h (gfc_new_charlen): New prototype. * iresolve.c (check_charlen_present,gfc_resolve_char_achar): Use new function gfc_new_charlen. * module.c (mio_charlen): Ditto. * resolve.c (gfc_resolve_substring_charlen, gfc_resolve_character_operator,fixup_charlen,resolve_fl_derived, resolve_symbol): Ditto. * symbol.c (gfc_new_charlen): New function to create a new gfc_charlen structure and add it to a namespace. (gfc_copy_formal_args_intr): Make sure ts.cl is present for CHARACTER variables. 2009-07-24 Janus Weil PR fortran/40822 * gfortran.dg/char_length_16.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150047 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index a8f9f6a213e..df399b90e7d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1681,9 +1681,7 @@ gfc_simplify_expr (gfc_expr *p, int type) gfc_free (p->value.character.string); p->value.character.string = s; p->value.character.length = end - start; - p->ts.cl = gfc_get_charlen (); - p->ts.cl->next = gfc_current_ns->cl_list; - gfc_current_ns->cl_list = p->ts.cl; + p->ts.cl = gfc_new_charlen (gfc_current_ns); p->ts.cl->length = gfc_int_expr (p->value.character.length); gfc_free_ref_list (p->ref); p->ref = NULL; -- cgit v1.2.1 From de0c4488fdfa38f2c6c01b098b416b8772572e54 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 9 Aug 2009 08:35:36 +0000 Subject: 2009-08-05 Tobias Burnus PR fortran/40955 * gfortran.h (ext_attr_id_t): Add typedef for this enum. (gfc_add_ext_attribute): Use it. * decl.c (gfc_match_gcc_attributes): Ditto. * expr.c (gfc_check_pointer_assign): Ditto. * symbol.c (gfc_add_ext_attribute): Ditto. (gfc_copy_attr): Copy also ext_attr. * resolve.c (resolve_fl_derived,resolve_symbol): Ditto. * module.c (mio_symbol_attribute): Save ext_attr in the mod * file. 2009-08-05 Tobias Burnus PR fortran/40955 * gfortran.dg/module_md5_1.f90: Update MD5 check sum. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150589 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index df399b90e7d..b0e58b3d6c4 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3195,9 +3195,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) symbol_attribute cdecl, stdcall, fastcall; unsigned calls; - gfc_add_ext_attribute (&cdecl, (unsigned) EXT_ATTR_CDECL, NULL); - gfc_add_ext_attribute (&stdcall, (unsigned) EXT_ATTR_STDCALL, NULL); - gfc_add_ext_attribute (&fastcall, (unsigned) EXT_ATTR_FASTCALL, NULL); + gfc_add_ext_attribute (&cdecl, EXT_ATTR_CDECL, NULL); + gfc_add_ext_attribute (&stdcall, EXT_ATTR_STDCALL, NULL); + gfc_add_ext_attribute (&fastcall, EXT_ATTR_FASTCALL, NULL); calls = cdecl.ext_attr | stdcall.ext_attr | fastcall.ext_attr; if ((calls & lvalue->symtree->n.sym->attr.ext_attr) -- cgit v1.2.1 From 0266d75cdea0b4faaead7bc55388fd06cceb911c Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 12 Aug 2009 09:03:38 +0000 Subject: 2009-08-12 Tobias Burnus PR fortran/41034 * symbol.c (gfc_copy_attr): Merge bits instead of replace bits in gfc_copy_attr. * gfc_check_pointer_assign (gfc_check_pointer_assign): Initialize ext_attr bits by zero. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150678 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index b0e58b3d6c4..b8d54e7dea1 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3192,16 +3192,15 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) && lvalue->symtree->n.sym->attr.ext_attr != rvalue->symtree->n.sym->attr.ext_attr) { - symbol_attribute cdecl, stdcall, fastcall; - unsigned calls; + symbol_attribute calls; - gfc_add_ext_attribute (&cdecl, EXT_ATTR_CDECL, NULL); - gfc_add_ext_attribute (&stdcall, EXT_ATTR_STDCALL, NULL); - gfc_add_ext_attribute (&fastcall, EXT_ATTR_FASTCALL, NULL); - calls = cdecl.ext_attr | stdcall.ext_attr | fastcall.ext_attr; + calls.ext_attr = 0; + gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL); + gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL); + gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL); - if ((calls & lvalue->symtree->n.sym->attr.ext_attr) - != (calls & rvalue->symtree->n.sym->attr.ext_attr)) + if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) + != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) { gfc_error ("Mismatch in the procedure pointer assignment " "at %L: mismatch in the calling convention", -- 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/expr.c | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index b8d54e7dea1..85c0cea644c 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1504,14 +1504,14 @@ simplify_const_ref (gfc_expr *p) else string_len = 0; - if (!p->ts.cl) + if (!p->ts.u.cl) { - p->ts.cl = gfc_get_charlen (); - p->ts.cl->next = NULL; - p->ts.cl->length = NULL; + p->ts.u.cl = gfc_get_charlen (); + p->ts.u.cl->next = NULL; + p->ts.u.cl->length = NULL; } - gfc_free_expr (p->ts.cl->length); - p->ts.cl->length = gfc_int_expr (string_len); + gfc_free_expr (p->ts.u.cl->length); + p->ts.u.cl->length = gfc_int_expr (string_len); } } gfc_free_ref_list (p->ref); @@ -1681,8 +1681,8 @@ gfc_simplify_expr (gfc_expr *p, int type) gfc_free (p->value.character.string); p->value.character.string = s; p->value.character.length = end - start; - p->ts.cl = gfc_new_charlen (gfc_current_ns); - p->ts.cl->length = gfc_int_expr (p->value.character.length); + p->ts.u.cl = gfc_new_charlen (gfc_current_ns); + p->ts.u.cl->length = gfc_int_expr (p->value.character.length); gfc_free_ref_list (p->ref); p->ref = NULL; p->expr_type = EXPR_CONSTANT; @@ -2102,7 +2102,7 @@ check_inquiry (gfc_expr *e, int not_restricted) with LEN, as required by the standard. */ if (i == 5 && not_restricted && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER - && ap->expr->symtree->n.sym->ts.cl->length == NULL) + && ap->expr->symtree->n.sym->ts.u.cl->length == NULL) { gfc_error ("Assumed character length variable '%s' in constant " "expression at %L", e->symtree->n.sym->name, &e->where); @@ -3337,7 +3337,7 @@ gfc_default_initializer (gfc_typespec *ts) gfc_component *c; /* See if we have a default initializer. */ - for (c = ts->derived->components; c; c = c->next) + for (c = ts->u.derived->components; c; c = c->next) if (c->initializer || c->attr.allocatable) break; @@ -3348,10 +3348,10 @@ gfc_default_initializer (gfc_typespec *ts) init = gfc_get_expr (); init->expr_type = EXPR_STRUCTURE; init->ts = *ts; - init->where = ts->derived->declared_at; + init->where = ts->u.derived->declared_at; tail = NULL; - for (c = ts->derived->components; c; c = c->next) + for (c = ts->u.derived->components; c; c = c->next) { if (tail == NULL) init->value.constructor = tail = gfc_get_constructor (); @@ -3421,10 +3421,10 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, return true; if (expr->ts.type == BT_CHARACTER - && expr->ts.cl - && expr->ts.cl->length - && expr->ts.cl->length->expr_type != EXPR_CONSTANT - && gfc_traverse_expr (expr->ts.cl->length, sym, func, f)) + && expr->ts.u.cl + && expr->ts.u.cl->length + && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT + && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) return true; switch (expr->expr_type) @@ -3502,11 +3502,11 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, case REF_COMPONENT: if (ref->u.c.component->ts.type == BT_CHARACTER - && ref->u.c.component->ts.cl - && ref->u.c.component->ts.cl->length - && ref->u.c.component->ts.cl->length->expr_type + && ref->u.c.component->ts.u.cl + && ref->u.c.component->ts.u.cl->length + && ref->u.c.component->ts.u.cl->length->expr_type != EXPR_CONSTANT - && gfc_traverse_expr (ref->u.c.component->ts.cl->length, + && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, sym, func, f)) return true; -- cgit v1.2.1 From d270ce529b4bdd51b952f8ed87746b9e77ada4c2 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 17 Aug 2009 09:11:00 +0000 Subject: 2009-08-17 Janus Weil PR fortran/40877 * array.c (gfc_resolve_character_array_constructor): Add NULL argument to gfc_new_charlen. * decl.c (add_init_expr_to_sym,variable_decl,match_char_spec, gfc_match_implicit): Ditto. * expr.c (simplify_const_ref): Fix memory leak. (gfc_simplify_expr): Add NULL argument to gfc_new_charlen. * gfortran.h (gfc_new_charlen): Modified prototype. * iresolve.c (check_charlen_present,gfc_resolve_char_achar): Add NULL argument to gfc_new_charlen. * module.c (mio_charlen): Ditto. * resolve.c (gfc_resolve_substring_charlen, gfc_resolve_character_operator,fixup_charlen): Ditto. (resolve_fl_derived,resolve_symbol): Add argument to gfc_charlen. * symbol.c (gfc_new_charlen): Add argument 'old_cl' (to make a copy of an existing charlen). (gfc_set_default_type,generate_isocbinding_symbol): Fix memory leak. (gfc_copy_formal_args_intr): Add NULL argument to gfc_new_charlen. * trans-decl.c (create_function_arglist): Fix memory leak. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150823 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 85c0cea644c..57582a9fc47 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1505,12 +1505,11 @@ simplify_const_ref (gfc_expr *p) string_len = 0; if (!p->ts.u.cl) - { - p->ts.u.cl = gfc_get_charlen (); - p->ts.u.cl->next = NULL; - p->ts.u.cl->length = NULL; - } - gfc_free_expr (p->ts.u.cl->length); + p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, + NULL); + else + gfc_free_expr (p->ts.u.cl->length); + p->ts.u.cl->length = gfc_int_expr (string_len); } } @@ -1681,7 +1680,7 @@ gfc_simplify_expr (gfc_expr *p, int type) gfc_free (p->value.character.string); p->value.character.string = s; p->value.character.length = end - start; - p->ts.u.cl = gfc_new_charlen (gfc_current_ns); + p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); p->ts.u.cl->length = gfc_int_expr (p->value.character.length); gfc_free_ref_list (p->ref); p->ref = NULL; -- cgit v1.2.1 From 10e9d5ee9cdd7a24dead20d3db2702644e5b580f Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 27 Aug 2009 19:48:46 +0000 Subject: 2009-08-27 Janus Weil PR fortran/40869 * expr.c (gfc_check_pointer_assign): Enable interface check for pointer assignments involving procedure pointer components. * gfortran.h (gfc_compare_interfaces): Modified prototype. * interface.c (gfc_compare_interfaces): Add argument 'name2', to be used instead of s2->name. Don't rely on the proc_pointer attribute, but instead on the flags handed to this function. (check_interface1,compare_parameter): Add argument for gfc_compare_interfaces. * resolve.c (check_generic_tbp_ambiguity): Ditto. 2009-08-27 Janus Weil PR fortran/40869 * gfortran.dg/proc_ptr_comp_20.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151147 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 39 ++++++++++++++++++++++++++++----------- 1 file changed, 28 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 57582a9fc47..970c25939cf 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3149,6 +3149,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (proc_pointer) { char err[200]; + gfc_symbol *s1,*s2; + gfc_component *comp; + const char *name; + attr = gfc_expr_attr (rvalue); if (!((rvalue->expr_type == EXPR_NULL) || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) @@ -3208,22 +3212,35 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } } - /* TODO: Enable interface check for PPCs. */ - if (gfc_is_proc_ptr_comp (rvalue, NULL)) - return SUCCESS; - if ((rvalue->expr_type == EXPR_VARIABLE - && !gfc_compare_interfaces (lvalue->symtree->n.sym, - rvalue->symtree->n.sym, 0, 1, err, - sizeof(err))) - || (rvalue->expr_type == EXPR_FUNCTION - && !gfc_compare_interfaces (lvalue->symtree->n.sym, - rvalue->symtree->n.sym->result, 0, 1, - err, sizeof(err)))) + if (gfc_is_proc_ptr_comp (lvalue, &comp)) + s1 = comp->ts.interface; + else + s1 = lvalue->symtree->n.sym; + + if (gfc_is_proc_ptr_comp (rvalue, &comp)) + { + s2 = comp->ts.interface; + name = comp->name; + } + else if (rvalue->expr_type == EXPR_FUNCTION) + { + s2 = rvalue->symtree->n.sym->result; + name = rvalue->symtree->n.sym->result->name; + } + else + { + s2 = rvalue->symtree->n.sym; + name = rvalue->symtree->n.sym->name; + } + + if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1, + err, sizeof(err))) { gfc_error ("Interface mismatch in procedure pointer assignment " "at %L: %s", &rvalue->where, err); 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/expr.c | 45 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 41 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 970c25939cf..32aa68265bb 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -330,6 +330,36 @@ gfc_has_vector_index (gfc_expr *e) } +/* Insert a reference to the component of the given name. + Only to be used with CLASS containers. */ + +void +gfc_add_component_ref (gfc_expr *e, const char *name) +{ + gfc_ref **tail = &(e->ref); + gfc_ref *next = NULL; + gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; + while (*tail != NULL) + { + if ((*tail)->type == REF_COMPONENT) + derived = (*tail)->u.c.component->ts.u.derived; + if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) + break; + tail = &((*tail)->next); + } + if (*tail != NULL && strcmp (name, "$data") == 0) + next = *tail; + (*tail) = gfc_get_ref(); + (*tail)->next = next; + (*tail)->type = REF_COMPONENT; + (*tail)->u.c.sym = derived; + (*tail)->u.c.component = gfc_find_component (derived, name, true, true); + gcc_assert((*tail)->u.c.component); + if (!next) + e->ts = (*tail)->u.c.component->ts; +} + + /* Copy a shape array. */ mpz_t * @@ -481,6 +511,7 @@ gfc_copy_expr (gfc_expr *p) case BT_HOLLERITH: case BT_LOGICAL: case BT_DERIVED: + case BT_CLASS: break; /* Already done. */ case BT_PROCEDURE: @@ -3124,7 +3155,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } - if (!pointer && !proc_pointer) + if (!pointer && !proc_pointer + && !(lvalue->ts.type == BT_CLASS + && lvalue->ts.u.derived->components->attr.pointer)) { gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); return FAILURE; @@ -3244,7 +3277,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return SUCCESS; } - if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) + if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS + && !gfc_compare_types (&lvalue->ts, &rvalue->ts)) { gfc_error ("Different types in pointer assignment at %L; attempted " "assignment of %s to %s", &lvalue->where, @@ -3252,7 +3286,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } - if (lvalue->ts.kind != rvalue->ts.kind) + if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) { gfc_error ("Different kind type parameters in pointer " "assignment at %L", &lvalue->where); @@ -3332,7 +3366,10 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) lvalue.symtree->n.sym = sym; lvalue.where = sym->declared_at; - if (sym->attr.pointer || sym->attr.proc_pointer) + if (sym->attr.pointer || sym->attr.proc_pointer + || (sym->ts.type == BT_CLASS + && sym->ts.u.derived->components->attr.pointer + && rvalue->expr_type == EXPR_NULL)) r = gfc_check_pointer_assign (&lvalue, rvalue); else r = gfc_check_assign (&lvalue, rvalue, 1); -- cgit v1.2.1 From cd62bad79a89b57a105448aba8130fdfb88c0382 Mon Sep 17 00:00:00 2001 From: janus Date: Wed, 7 Oct 2009 10:54:35 +0000 Subject: 2009-10-07 Janus Weil * expr.c (gfc_check_pointer_assign): Do the correct type checking when CLASS variables are involved. * match.c (gfc_match_select_type): Parse associate-name in SELECT TYPE statements, and set up a local namespace for the SELECT TYPE block. * parse.h (gfc_build_block_ns): New prototype. * parse.c (parse_select_type_block): Return from local namespace to its parent after SELECT TYPE block. (gfc_build_block_ns): New function for setting up the local namespace for a BLOCK construct. (parse_block_construct): Use gfc_build_block_ns. * resolve.c (resolve_select_type): Insert assignment for the selector variable, in case an associate-name is given, and put the SELECT TYPE statement inside a BLOCK. (resolve_code): Call resolve_class_assign after checking the assignment. * symbol.c (gfc_find_sym_tree): Moved some code here from gfc_get_ha_sym_tree. (gfc_get_ha_sym_tree): Moved some code to gfc_find_sym_tree. 2009-10-07 Janus Weil * gfortran.dg/same_type_as_2.f03: Modified (was illegal). * gfortran.dg/select_type_1.f03: Modified error message. * gfortran.dg/select_type_5.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152526 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 32aa68265bb..cbd3172b454 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3277,8 +3277,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return SUCCESS; } - if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS - && !gfc_compare_types (&lvalue->ts, &rvalue->ts)) + if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) { gfc_error ("Different types in pointer assignment at %L; attempted " "assignment of %s to %s", &lvalue->where, -- cgit v1.2.1 From 0f77e4b8530980a42d981b38f6295a71ae02bc74 Mon Sep 17 00:00:00 2001 From: ghazi Date: Mon, 7 Dec 2009 15:32:43 +0000 Subject: PR other/40302 * arith.c: Remove HAVE_mpc* checks throughout. * expr.c: Likewise. * gfortran.h: Likewise. * resolve.c: Likewise. * simplify.c: Likewise. * target-memory.c: Likewise. * target-memory.h: Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155043 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 12 ------------ 1 file changed, 12 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index cbd3172b454..c693773ebf2 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -156,12 +156,7 @@ free_expr0 (gfc_expr *e) break; case BT_COMPLEX: -#ifdef HAVE_mpc mpc_clear (e->value.complex); -#else - mpfr_clear (e->value.complex.r); - mpfr_clear (e->value.complex.i); -#endif break; default: @@ -473,15 +468,8 @@ gfc_copy_expr (gfc_expr *p) case BT_COMPLEX: gfc_set_model_kind (q->ts.kind); -#ifdef HAVE_mpc mpc_init2 (q->value.complex, mpfr_get_default_prec()); mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); -#else - mpfr_init (q->value.complex.r); - mpfr_init (q->value.complex.i); - mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE); - mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE); -#endif break; case BT_CHARACTER: -- cgit v1.2.1 From 0c54ae75e67742522f331dce5db1fe0983d42ca6 Mon Sep 17 00:00:00 2001 From: dfranke Date: Thu, 10 Dec 2009 19:57:16 +0000 Subject: gcc/fortran/: 2009-12-10 Daniel Franke PR fortran/34402 * expr.c (check_alloc_comp_init): New. (check_init_expr): Verify that allocatable components are not data-initalized. gcc/testsuite/: 2009-12-10 Daniel Franke PR fortran/34402 * gfortran.dg/alloc_comp_init_expr.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155138 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 42 ++++++++++++++++++++++++++++++++++++++---- 1 file changed, 38 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index c693773ebf2..f0cfd189628 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2034,6 +2034,32 @@ not_numeric: return FAILURE; } +/* F2003, 7.1.7 (3): In init expression, allocatable components + must not be data-initialized. */ +static gfc_try +check_alloc_comp_init (gfc_expr *e) +{ + gfc_component *c; + 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) + { + if (c->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); + return FAILURE; + } + } + + return SUCCESS; +} static match check_init_expr_arguments (gfc_expr *e) @@ -2383,10 +2409,18 @@ check_init_expr (gfc_expr *e) break; case EXPR_STRUCTURE: - if (e->ts.is_iso_c) - t = SUCCESS; - else - t = gfc_check_constructor (e, check_init_expr); + t = e->ts.is_iso_c ? SUCCESS : FAILURE; + if (t == SUCCESS) + break; + + t = check_alloc_comp_init (e); + if (t == FAILURE) + break; + + t = gfc_check_constructor (e, check_init_expr); + if (t == FAILURE) + break; + break; case EXPR_ARRAY: -- cgit v1.2.1 From 8c2c51e82e7f9bab7ba3eb60b1dc5a7bfbb12673 Mon Sep 17 00:00:00 2001 From: dfranke Date: Fri, 11 Dec 2009 21:08:39 +0000 Subject: 2009-12-11 Daniel Franke PR fortran/40290 * expr.c (gfc_type_convert_binary): Added warn-on-conversion flag, passed on to gfc_convert_type_warn() instead of gfc_convert_type(); enabled warnings on all callers but ... * arith.c (eval_intrinsic): Disabled warnings on implicit type conversion. * gfortran.h gfc_type_convert_binary): Adjusted prototype. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155179 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index f0cfd189628..35918a69f9d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -653,7 +653,8 @@ gfc_build_conversion (gfc_expr *e) /* Given an expression node with some sort of numeric binary expression, insert type conversions required to make the operands - have the same type. + have the same type. Conversion warnings are disabled if wconversion + is set to 0. The exception is that the operands of an exponential don't have to have the same type. If possible, the base is promoted to the type @@ -661,7 +662,7 @@ gfc_build_conversion (gfc_expr *e) 1.0**2 stays as it is. */ void -gfc_type_convert_binary (gfc_expr *e) +gfc_type_convert_binary (gfc_expr *e, int wconversion) { gfc_expr *op1, *op2; @@ -685,9 +686,9 @@ gfc_type_convert_binary (gfc_expr *e) } if (op1->ts.kind > op2->ts.kind) - gfc_convert_type (op2, &op1->ts, 2); + gfc_convert_type_warn (op2, &op1->ts, 2, wconversion); else - gfc_convert_type (op1, &op2->ts, 2); + gfc_convert_type_warn (op1, &op2->ts, 2, wconversion); e->ts = op1->ts; goto done; @@ -702,14 +703,14 @@ gfc_type_convert_binary (gfc_expr *e) if (e->value.op.op == INTRINSIC_POWER) goto done; - gfc_convert_type (e->value.op.op2, &e->ts, 2); + gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); goto done; } if (op1->ts.type == BT_INTEGER) { e->ts = op2->ts; - gfc_convert_type (e->value.op.op1, &e->ts, 2); + gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); goto done; } @@ -720,9 +721,9 @@ gfc_type_convert_binary (gfc_expr *e) else e->ts.kind = op2->ts.kind; if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) - gfc_convert_type (e->value.op.op1, &e->ts, 2); + gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) - gfc_convert_type (e->value.op.op2, &e->ts, 2); + gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); done: return; -- cgit v1.2.1 From 3ac13aaeaee10ffc91ce798a720559fd654d01c1 Mon Sep 17 00:00:00 2001 From: dfranke Date: Mon, 14 Dec 2009 19:10:56 +0000 Subject: gcc/fortran/: 2009-12-14 Daniel Franke PR fortran/42354 * expr.c (check_init_expr): Do not check for specification functions. gcc/testsuite/: 2009-12-14 Daniel Franke PR fortran/42354 * gfortran.dg/iso_c_binding_init_expr.f03: New. * gfortran.dg/intrinsic_std_1.f90: Fixed expected error message. * gfortran.dg/function_kinds_5.f90: Likewise. * gfortran.dg/selected_char_kind_3.f90: Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155234 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 61 +++++++++++++++++++++++++++--------------------------- 1 file changed, 30 insertions(+), 31 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 35918a69f9d..72420ff01b5 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2286,40 +2286,39 @@ check_init_expr (gfc_expr *e) case EXPR_FUNCTION: t = FAILURE; - if ((m = check_specification_function (e)) != MATCH_YES) - { - gfc_intrinsic_sym* isym; - gfc_symbol* sym; + { + gfc_intrinsic_sym* isym; + gfc_symbol* sym; - sym = e->symtree->n.sym; - if (!gfc_is_intrinsic (sym, 0, e->where) - || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES) - { - gfc_error ("Function '%s' in initialization expression at %L " - "must be an intrinsic or a specification function", - e->symtree->n.sym->name, &e->where); - break; - } + sym = e->symtree->n.sym; + if (!gfc_is_intrinsic (sym, 0, e->where) + || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES) + { + gfc_error ("Function '%s' in initialization expression at %L " + "must be an intrinsic function", + e->symtree->n.sym->name, &e->where); + break; + } - if ((m = check_conversion (e)) == MATCH_NO - && (m = check_inquiry (e, 1)) == MATCH_NO - && (m = check_null (e)) == MATCH_NO - && (m = check_transformational (e)) == MATCH_NO - && (m = check_elemental (e)) == MATCH_NO) - { - gfc_error ("Intrinsic function '%s' at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - m = MATCH_ERROR; - } + if ((m = check_conversion (e)) == MATCH_NO + && (m = check_inquiry (e, 1)) == MATCH_NO + && (m = check_null (e)) == MATCH_NO + && (m = check_transformational (e)) == MATCH_NO + && (m = check_elemental (e)) == MATCH_NO) + { + gfc_error ("Intrinsic function '%s' at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + m = MATCH_ERROR; + } - /* Try to scalarize an elemental intrinsic function that has an - array argument. */ - isym = gfc_find_function (e->symtree->n.sym->name); - if (isym && isym->elemental - && (t = scalarize_intrinsic_call (e)) == SUCCESS) - break; - } + /* Try to scalarize an elemental intrinsic function that has an + array argument. */ + isym = gfc_find_function (e->symtree->n.sym->name); + if (isym && isym->elemental + && (t = scalarize_intrinsic_call (e)) == SUCCESS) + break; + } if (m == MATCH_YES) t = gfc_simplify_expr (e, 0); -- cgit v1.2.1 From c315461d1a22ed500bc4d1f2897dddcb77a9e011 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Sat, 9 Jan 2010 17:47:04 +0000 Subject: 2010-01-09 Jerry DeLisle PR fortran/20923 PR fortran/32489 * trans-array.c (gfc_conv_array_initializer): Change call to gfc_error_now to call to gfc_fatal_error. * array.c (count_elements): Whitespace. (extract_element): Whitespace. (is_constant_element): Changed name from constant_element. (gfc_constant_ac): Only use expand_construuctor for expression types of EXPR_ARRAY. If expression type is EXPR_CONSTANT, no need to call gfc_is_constant_expr. * expr.c (gfc_reduce_init_expr): Adjust conditionals and delete error message. * resolve.c (gfc_is_expandable_expr): New function that determiners if array expressions should have their constructors expanded. (gfc_resolve_expr): Use new function to determine whether or not to call gfc_expand_constructor. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155769 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 72420ff01b5..8fa46d82f70 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2460,18 +2460,12 @@ gfc_reduce_init_expr (gfc_expr *expr) if (t == FAILURE) return FAILURE; - if (expr->expr_type == EXPR_ARRAY - && (gfc_check_constructor_type (expr) == FAILURE - || gfc_expand_constructor (expr) == FAILURE)) - return FAILURE; - - /* Not all inquiry functions are simplified to constant expressions - so it is necessary to call check_inquiry again. */ - if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES - && !gfc_in_match_data ()) + if (expr->expr_type == EXPR_ARRAY) { - gfc_error ("Initialization expression didn't reduce %C"); - return FAILURE; + if (gfc_check_constructor_type (expr) == FAILURE) + return FAILURE; + if (gfc_expand_constructor (expr) == FAILURE) + return FAILURE; } return SUCCESS; -- cgit v1.2.1 From 14c92e725d700f416c5b6909796d5d81f52d8880 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 24 Jan 2010 16:59:51 +0000 Subject: 2010-01-24 Paul Thomas PR fortran/41044 PR fortran/41167 * expr.c (remove_subobject_ref): If the constructor is NULL use the expression as the source. (simplify_const_ref): Change the type of expression if there are component references. Allow for substring to be at the end of an arbitrarily long chain of references. If an element is found that is not in an EXPR_ARRAY, assume that this is scalar initialization of array. Call remove_subobject_ref in this case with NULL second argument. 2010-01-24 Paul Thomas PR fortran/41044 * gfortran.dg/parameter_array_ref_2.f90 : New test. PR fortran/41167 * gfortran.dg/char_array_arg_1.f90 : New test. * gfortran.dg/pr25923.f90 : Remove XFAIL. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156197 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 42 +++++++++++++++++++++++++++++++----------- 1 file changed, 31 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 8fa46d82f70..d846c0f121e 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1154,8 +1154,13 @@ remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) { gfc_expr *e; - e = cons->expr; - cons->expr = NULL; + if (cons) + { + e = cons->expr; + cons->expr = NULL; + } + else + e = gfc_copy_expr (p); e->ref = p->ref->next; p->ref->next = NULL; gfc_replace_expr (p, e); @@ -1464,6 +1469,7 @@ simplify_const_ref (gfc_expr *p) { gfc_constructor *cons; gfc_expr *newp; + gfc_ref *last_ref; while (p->ref) { @@ -1473,6 +1479,13 @@ simplify_const_ref (gfc_expr *p) switch (p->ref->u.ar.type) { case AR_ELEMENT: + /* , parameter :: x() = scalar_expr + will generate this. */ + if (p->expr_type != EXPR_ARRAY) + { + remove_subobject_ref (p, NULL); + break; + } if (find_array_element (p->value.constructor, &p->ref->u.ar, &cons) == FAILURE) return FAILURE; @@ -1502,18 +1515,25 @@ simplify_const_ref (gfc_expr *p) return FAILURE; } - /* If this is a CHARACTER array and we possibly took a - substring out of it, update the type-spec's character - length according to the first element (as all should have - the same length). */ - if (p->ts.type == BT_CHARACTER) + if (p->ts.type == BT_DERIVED + && p->ref->next + && p->value.constructor) { - int string_len; + /* There may have been component references. */ + p->ts = p->value.constructor->expr->ts; + } - gcc_assert (p->ref->next); - gcc_assert (!p->ref->next->next); - gcc_assert (p->ref->next->type == REF_SUBSTRING); + last_ref = p->ref; + for (; last_ref->next; last_ref = last_ref->next) {}; + if (p->ts.type == BT_CHARACTER + && last_ref->type == REF_SUBSTRING) + { + /* If this is a CHARACTER array and we possibly took + a substring out of it, update the type-spec's + character length according to the first element + (as all should have the same length). */ + int string_len; if (p->value.constructor) { const gfc_expr* first = p->value.constructor->expr; -- cgit v1.2.1 From ffc91ac17fb327ea6eb30c38ebc8bb7add445af1 Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 31 Jan 2010 12:05:22 +0000 Subject: 2010-01-31 Paul Thomas PR fortran/38324 * expr.c (gfc_get_full_arrayspec_from_expr): New function. * gfortran.h : Add prototype for above. * trans-expr.c (gfc_trans_alloc_subarray_assign): New function. (gfc_trans_subcomponent_assign): Call new function to replace the code to deal with allocatable components. * trans-intrinsic.c (gfc_conv_intrinsic_bound): Call gfc_get_full_arrayspec_from_expr to replace existing code. 2010-01-31 Paul Thomas PR fortran/38324 * gfortran.dg/alloc_comp_basics_1.f90: Remove option -O2. * gfortran.dg/alloc_comp_bounds_1.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156399 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d846c0f121e..6d3ca8476b8 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3489,6 +3489,58 @@ gfc_get_variable_expr (gfc_symtree *var) } +/* Returns the array_spec of a full array expression. A NULL is + returned otherwise. */ +gfc_array_spec * +gfc_get_full_arrayspec_from_expr (gfc_expr *expr) +{ + gfc_array_spec *as; + gfc_ref *ref; + + if (expr->rank == 0) + return NULL; + + /* Follow any component references. */ + if (expr->expr_type == EXPR_VARIABLE + || expr->expr_type == EXPR_CONSTANT) + { + as = expr->symtree->n.sym->as; + for (ref = expr->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + continue; + + case REF_ARRAY: + { + switch (ref->u.ar.type) + { + case AR_ELEMENT: + case AR_SECTION: + case AR_UNKNOWN: + as = NULL; + continue; + + case AR_FULL: + break; + } + break; + } + } + } + } + else + as = NULL; + + return as; +} + + /* General expression traversal function. */ bool -- cgit v1.2.1 From 452695a8da676319b005b0fdfafc623139ea2f83 Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 17 Mar 2010 09:53:40 +0000 Subject: 2010-03-17 Tobias Burnus PR fortran/43331 * trans-array.c (gfc_conv_array_index_offset,gfc_conv_array_ref, gfc_conv_ss_startstride): Remove no-longer-needed cp_was_assumed check. * decl.c (gfc_match_derived_decl): Don't mark assumed-size Cray pointees as having explizit size. * expr.c (gfc_check_assign): Remove now unreachable Cray pointee check. * trans-types.c (gfc_is_nodesc_array): Add cp_was_assumed to * assert. (gfc_sym_type): Don't mark Cray pointees as restricted pointers. * resolve.c (resolve_symbol): Handle cp_was_assumed. * trans-decl.c (gfc_trans_deferred_vars): Ditto. (gfc_finish_var_decl): Don't mark Cray pointees as restricted pointers. 2010-03-17 Tobias Burnus PR fortran/43331 * gfortran.dg/cray_pointers_1.f90: Update dg-error message. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157512 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 10 ---------- 1 file changed, 10 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 6d3ca8476b8..58c906375ea 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3010,16 +3010,6 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) } } - if (sym->attr.cray_pointee - && lvalue->ref != NULL - && lvalue->ref->u.ar.type == AR_FULL - && lvalue->ref->u.ar.as->cp_was_assumed) - { - gfc_error ("Vector assignment to assumed-size Cray Pointee at %L " - "is illegal", &lvalue->where); - return FAILURE; - } - /* This is possibly a typo: x = f() instead of x => f(). */ if (gfc_option.warn_surprising && rvalue->expr_type == EXPR_FUNCTION -- cgit v1.2.1 From 1384ae99ee84aa34f559ffb29468099e22d88dd2 Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 1 Apr 2010 18:06:05 +0000 Subject: 2010-04-01 Paul Thomas * ioparm.def : Update copyright. * lang.opt : ditto * trans-array.c : ditto * trans-array.h : ditto * expr.c: ditto * trans-types.c: ditto * dependency.c : ditto * gfortran.h : ditto * options.c : ditto * trans-io.c : ditto * trans-intrinsic.c : ditto * libgfortran.h : ditto * invoke.texi : ditto * intrinsic.texi : ditto * trans.c : ditto * trans.h : ditto * intrinsic.c : ditto * interface.c : ditto * iresolve.c : ditto * trans-stmt.c : ditto * trans-stmt.h : ditto * parse,c : ditto * match.h : ditto * error.c : ditto git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157923 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 58c906375ea..d85f23cd2ad 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1,5 +1,6 @@ /* Routines for manipulation of expression nodes. - 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 -- cgit v1.2.1 From e97ac7c06c53487872b7d9d11148725317ef5588 Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 9 Apr 2010 05:54:29 +0000 Subject: 2010-04-09 Tobias Burnus PR fortran/18918 * decl.c (variable_decl, match_attr_spec): Fix setting the array spec. * array.c (match_subscript,gfc_match_array_ref): Add coarray * support. * data.c (gfc_assign_data_value): Ditto. * expr.c (gfc_check_pointer_assign): Add check for coarray * constraint. (gfc_traverse_expr): Traverse also through codimension expressions. (gfc_is_coindexed, gfc_has_ultimate_allocatable, gfc_has_ultimate_pointer): New functions. * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for * coarrays. (gfc_array_ref): Add codimen. (gfc_array_ref): Add in_allocate. (gfc_is_coindexed, gfc_has_ultimate_allocatable, gfc_has_ultimate_pointer): Add prototypes. * interface.c (compare_parameter, compare_actual_formal, check_intents): Add coarray constraints. * match.c (gfc_match_iterator): Add coarray constraint. * match.h (gfc_match_array_ref): Update interface. * primary.c (gfc_match_varspec): Handle codimensions. * resolve.c (coarray_alloc, inquiry_argument): New static * variables. (check_class_members): Return gfc_try instead for error recovery. (resolve_typebound_function,resolve_typebound_subroutine, check_members): Handle return value of check_class_members. (resolve_structure_cons, resolve_actual_arglist, resolve_function, check_dimension, compare_spec_to_ref, resolve_array_ref, resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays, resolve_allocate_expr, resolve_ordinary_assign): Add coarray support. * trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr): Skip over coarray refs. (gfc_array_allocate) Add support for references containing coindexes. * trans-expr.c (gfc_add_interface_mapping): Copy coarray * attribute. (gfc_map_intrinsic_function): Ignore codimensions. 2010-04-09 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_7.f90: New test. * gfortran.dg/coarray_8.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158149 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 103 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 102 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d85f23cd2ad..2200a805b44 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3205,6 +3205,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) return SUCCESS; + /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ + if (lvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (lvalue)) + { + gfc_ref *ref; + for (ref = lvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Pointer object at %L shall not have a coindex", + &lvalue->where); + return FAILURE; + } + } + /* Checks on rvalue for procedure pointer assignments. */ if (proc_pointer) { @@ -3369,6 +3383,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } + /* F2008, C725. For PURE also C1283. */ + if (rvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (rvalue)) + { + gfc_ref *ref; + for (ref = rvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Data target at %L shall not have a coindex", + &rvalue->where); + return FAILURE; + } + } + return SUCCESS; } @@ -3642,7 +3670,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, return true; if (ref->u.c.component->as) - for (i = 0; i < ref->u.c.component->as->rank; i++) + for (i = 0; i < ref->u.c.component->as->rank + + ref->u.c.component->as->corank; i++) { if (gfc_traverse_expr (ref->u.c.component->as->lower[i], sym, func, f)) @@ -3836,3 +3865,75 @@ gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest) gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0); } + +bool +gfc_is_coindexed (gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return true; + + return false; +} + + +/* Check whether the expression has an ultimate allocatable component. + Being itself allocatable does not count. */ +bool +gfc_has_ultimate_allocatable (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return last->u.c.component->ts.u.derived->components->attr.alloc_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.alloc_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return e->ts.u.derived->components->attr.alloc_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.alloc_comp; + else + return false; +} + + +/* Check whether the expression has an pointer component. + Being itself a pointer does not count. */ +bool +gfc_has_ultimate_pointer (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return last->u.c.component->ts.u.derived->components->attr.pointer_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.pointer_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return e->ts.u.derived->components->attr.pointer_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.pointer_comp; + else + return false; +} -- cgit v1.2.1 From 21d5f487989f058b0641f386266bea540dc31aa2 Mon Sep 17 00:00:00 2001 From: burnus Date: Sat, 10 Apr 2010 14:24:46 +0000 Subject: 2010-04-10 Tobias Burnus PR fortran/43591 * expr.c (gfc_is_constant_expr, gfc_traverse_expr): Handle proc-pointers and type-bound procedures. (gfc_specification_expr): Check proc-pointers for pureness. 2010-04-10 Tobias Burnus PR fortran/43591 * gfortran.dg/spec_expr_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158191 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 2200a805b44..9e2beb6a539 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -782,6 +782,8 @@ gfc_is_constant_expr (gfc_expr *e) break; case EXPR_FUNCTION: + case EXPR_PPC: + case EXPR_COMPCALL: /* Specification functions are constant. */ if (check_specification_function (e) == MATCH_YES) { @@ -2808,6 +2810,7 @@ check_restricted (gfc_expr *e) gfc_try gfc_specification_expr (gfc_expr *e) { + gfc_component *comp; if (e == NULL) return SUCCESS; @@ -2822,7 +2825,9 @@ gfc_specification_expr (gfc_expr *e) if (e->expr_type == EXPR_FUNCTION && !e->value.function.isym && !e->value.function.esym - && !gfc_pure (e->symtree->n.sym)) + && !gfc_pure (e->symtree->n.sym) + && (!gfc_is_proc_ptr_comp (e, &comp) + || !comp->attr.pure)) { gfc_error ("Function '%s' at %L must be PURE", e->symtree->n.sym->name, &e->where); @@ -3588,6 +3593,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, switch (expr->expr_type) { + case EXPR_PPC: + case EXPR_COMPCALL: case EXPR_FUNCTION: for (args = expr->value.function.actual; args; args = args->next) { -- 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/expr.c | 956 ++++++++++++++++++++++++++++++----------------------- 1 file changed, 545 insertions(+), 411 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 9e2beb6a539..700fd10f6fe 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -26,8 +26,19 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "match.h" #include "target-memory.h" /* for gfc_convert_boz */ +#include "constructor.h" -/* Get a new expr node. */ + +/* The following set of functions provide access to gfc_expr* of + various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE. + + There are two functions available elsewhere that provide + slightly different flavours of variables. Namely: + expr.c (gfc_get_variable_expr) + symbol.c (gfc_lval_expr_from_sym) + TODO: Merge these functions, if possible. */ + +/* Get a new expression node. */ gfc_expr * gfc_get_expr (void) @@ -39,92 +50,349 @@ gfc_get_expr (void) e->shape = NULL; e->ref = NULL; e->symtree = NULL; - e->con_by_offset = NULL; return e; } -/* Free an argument list and everything below it. */ +/* Get a new expression node that is an array constructor + of given type and kind. */ -void -gfc_free_actual_arglist (gfc_actual_arglist *a1) +gfc_expr * +gfc_get_array_expr (bt type, int kind, locus *where) { - gfc_actual_arglist *a2; + gfc_expr *e; - while (a1) - { - a2 = a1->next; - gfc_free_expr (a1->expr); - gfc_free (a1); - a1 = a2; - } + e = gfc_get_expr (); + e->expr_type = EXPR_ARRAY; + e->value.constructor = NULL; + e->rank = 1; + e->shape = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; } -/* Copy an arglist structure and all of the arguments. */ +/* Get a new expression node that is the NULL expression. */ -gfc_actual_arglist * -gfc_copy_actual_arglist (gfc_actual_arglist *p) +gfc_expr * +gfc_get_null_expr (locus *where) { - gfc_actual_arglist *head, *tail, *new_arg; + gfc_expr *e; - head = tail = NULL; + e = gfc_get_expr (); + e->expr_type = EXPR_NULL; + e->ts.type = BT_UNKNOWN; - for (; p; p = p->next) + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an operator expression node. */ + +gfc_expr * +gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, + gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_OP; + e->value.op.op = op; + e->value.op.op1 = op1; + e->value.op.op2 = op2; + + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an structure constructor + of given type and kind. */ + +gfc_expr * +gfc_get_structure_constructor_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_STRUCTURE; + e->value.constructor = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an constant of given type and kind. */ + +gfc_expr * +gfc_get_constant_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + if (!where) + gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL"); + + e = gfc_get_expr (); + + e->expr_type = EXPR_CONSTANT; + e->ts.type = type; + e->ts.kind = kind; + e->where = *where; + + switch (type) { - new_arg = gfc_get_actual_arglist (); - *new_arg = *p; + case BT_INTEGER: + mpz_init (e->value.integer); + break; - new_arg->expr = gfc_copy_expr (p->expr); - new_arg->next = NULL; + case BT_REAL: + gfc_set_model_kind (kind); + mpfr_init (e->value.real); + break; - if (head == NULL) - head = new_arg; - else - tail->next = new_arg; + case BT_COMPLEX: + gfc_set_model_kind (kind); + mpc_init2 (e->value.complex, mpfr_get_default_prec()); + break; - tail = new_arg; + default: + break; } - return head; + return e; } -/* Free a list of reference structures. */ +/* Get a new expression node that is an string constant. + If no string is passed, a string of len is allocated, + blanked and null-terminated. */ -void -gfc_free_ref_list (gfc_ref *p) +gfc_expr * +gfc_get_character_expr (int kind, locus *where, const char *src, int len) { - gfc_ref *q; - int i; + gfc_expr *e; + gfc_char_t *dest; - for (; p; p = q) + if (!src) { - q = p->next; + dest = gfc_get_wide_string (len + 1); + gfc_wide_memset (dest, ' ', len); + dest[len] = '\0'; + } + else + dest = gfc_char_to_widechar (src); - switch (p->type) + e = gfc_get_constant_expr (BT_CHARACTER, kind, + where ? where : &gfc_current_locus); + e->value.character.string = dest; + e->value.character.length = len; + + return e; +} + + +/* Get a new expression node that is an integer constant. */ + +gfc_expr * +gfc_get_int_expr (int kind, locus *where, int value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_INTEGER, kind, + where ? where : &gfc_current_locus); + + mpz_init_set_si (p->value.integer, value); + + return p; +} + + +/* Get a new expression node that is a logical constant. */ + +gfc_expr * +gfc_get_logical_expr (int kind, locus *where, bool value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_LOGICAL, kind, + where ? where : &gfc_current_locus); + + p->value.logical = value; + + return p; +} + + +gfc_expr * +gfc_get_iokind_expr (locus *where, io_kind k) +{ + gfc_expr *e; + + /* Set the types to something compatible with iokind. This is needed to + get through gfc_free_expr later since iokind really has no Basic Type, + BT, of its own. */ + + e = gfc_get_expr (); + e->expr_type = EXPR_CONSTANT; + e->ts.type = BT_LOGICAL; + e->value.iokind = k; + e->where = *where; + + return e; +} + + +/* Given an expression pointer, return a copy of the expression. This + subroutine is recursive. */ + +gfc_expr * +gfc_copy_expr (gfc_expr *p) +{ + gfc_expr *q; + gfc_char_t *s; + char *c; + + if (p == NULL) + return NULL; + + q = gfc_get_expr (); + *q = *p; + + switch (q->expr_type) + { + case EXPR_SUBSTRING: + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + break; + + case EXPR_CONSTANT: + /* Copy target representation, if it exists. */ + if (p->representation.string) { - case REF_ARRAY: - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + c = XCNEWVEC (char, p->representation.length + 1); + q->representation.string = c; + memcpy (c, p->representation.string, (p->representation.length + 1)); + } + + /* Copy the values of any pointer components of p->value. */ + switch (q->ts.type) + { + case BT_INTEGER: + mpz_init_set (q->value.integer, p->value.integer); + break; + + case BT_REAL: + gfc_set_model_kind (q->ts.kind); + mpfr_init (q->value.real); + mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (q->ts.kind); + mpc_init2 (q->value.complex, mpfr_get_default_prec()); + mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); + break; + + case BT_CHARACTER: + if (p->representation.string) + q->value.character.string + = gfc_char_to_widechar (q->representation.string); + else { - gfc_free_expr (p->u.ar.start[i]); - gfc_free_expr (p->u.ar.end[i]); - gfc_free_expr (p->u.ar.stride[i]); - } + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + /* This is the case for the C_NULL_CHAR named constant. */ + if (p->value.character.length == 0 + && (p->ts.is_c_interop || p->ts.is_iso_c)) + { + *s = '\0'; + /* Need to set the length to 1 to make sure the NUL + terminator is copied. */ + q->value.character.length = 1; + } + else + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + } break; - case REF_SUBSTRING: - gfc_free_expr (p->u.ss.start); - gfc_free_expr (p->u.ss.end); + case BT_HOLLERITH: + case BT_LOGICAL: + case BT_DERIVED: + case BT_CLASS: + break; /* Already done. */ + + case BT_PROCEDURE: + case BT_VOID: + /* Should never be reached. */ + case BT_UNKNOWN: + gfc_internal_error ("gfc_copy_expr(): Bad expr node"); + /* Not reached. */ + } + + break; + + case EXPR_OP: + switch (q->value.op.op) + { + case INTRINSIC_NOT: + case INTRINSIC_PARENTHESES: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); break; - case REF_COMPONENT: + default: /* Binary operators. */ + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); + q->value.op.op2 = gfc_copy_expr (p->value.op.op2); break; } - gfc_free (p); + break; + + case EXPR_FUNCTION: + q->value.function.actual = + gfc_copy_actual_arglist (p->value.function.actual); + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + q->value.compcall.actual = + gfc_copy_actual_arglist (p->value.compcall.actual); + q->value.compcall.tbp = p->value.compcall.tbp; + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + q->value.constructor = gfc_constructor_copy (p->value.constructor); + break; + + case EXPR_VARIABLE: + case EXPR_NULL: + break; } + + q->shape = gfc_copy_shape (p->shape, p->rank); + + q->ref = gfc_copy_ref (p->ref); + + return q; } @@ -191,7 +459,7 @@ free_expr0 (gfc_expr *e) case EXPR_ARRAY: case EXPR_STRUCTURE: - gfc_free_constructor (e->value.constructor); + gfc_constructor_free (e->value.constructor); break; case EXPR_SUBSTRING: @@ -211,26 +479,108 @@ free_expr0 (gfc_expr *e) 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); + } } @@ -420,147 +770,6 @@ gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) } -/* Given an expression pointer, return a copy of the expression. This - subroutine is recursive. */ - -gfc_expr * -gfc_copy_expr (gfc_expr *p) -{ - gfc_expr *q; - gfc_char_t *s; - char *c; - - if (p == NULL) - return NULL; - - q = gfc_get_expr (); - *q = *p; - - switch (q->expr_type) - { - case EXPR_SUBSTRING: - s = gfc_get_wide_string (p->value.character.length + 1); - q->value.character.string = s; - memcpy (s, p->value.character.string, - (p->value.character.length + 1) * sizeof (gfc_char_t)); - break; - - case EXPR_CONSTANT: - /* Copy target representation, if it exists. */ - if (p->representation.string) - { - c = XCNEWVEC (char, p->representation.length + 1); - q->representation.string = c; - memcpy (c, p->representation.string, (p->representation.length + 1)); - } - - /* Copy the values of any pointer components of p->value. */ - switch (q->ts.type) - { - case BT_INTEGER: - mpz_init_set (q->value.integer, p->value.integer); - break; - - case BT_REAL: - gfc_set_model_kind (q->ts.kind); - mpfr_init (q->value.real); - mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model_kind (q->ts.kind); - mpc_init2 (q->value.complex, mpfr_get_default_prec()); - mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); - break; - - case BT_CHARACTER: - if (p->representation.string) - q->value.character.string - = gfc_char_to_widechar (q->representation.string); - else - { - s = gfc_get_wide_string (p->value.character.length + 1); - q->value.character.string = s; - - /* This is the case for the C_NULL_CHAR named constant. */ - if (p->value.character.length == 0 - && (p->ts.is_c_interop || p->ts.is_iso_c)) - { - *s = '\0'; - /* Need to set the length to 1 to make sure the NUL - terminator is copied. */ - q->value.character.length = 1; - } - else - memcpy (s, p->value.character.string, - (p->value.character.length + 1) * sizeof (gfc_char_t)); - } - break; - - case BT_HOLLERITH: - case BT_LOGICAL: - case BT_DERIVED: - case BT_CLASS: - break; /* Already done. */ - - case BT_PROCEDURE: - case BT_VOID: - /* Should never be reached. */ - case BT_UNKNOWN: - gfc_internal_error ("gfc_copy_expr(): Bad expr node"); - /* Not reached. */ - } - - break; - - case EXPR_OP: - switch (q->value.op.op) - { - case INTRINSIC_NOT: - case INTRINSIC_PARENTHESES: - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - q->value.op.op1 = gfc_copy_expr (p->value.op.op1); - break; - - default: /* Binary operators. */ - q->value.op.op1 = gfc_copy_expr (p->value.op.op1); - q->value.op.op2 = gfc_copy_expr (p->value.op.op2); - break; - } - - break; - - case EXPR_FUNCTION: - q->value.function.actual = - gfc_copy_actual_arglist (p->value.function.actual); - break; - - case EXPR_COMPCALL: - case EXPR_PPC: - q->value.compcall.actual = - gfc_copy_actual_arglist (p->value.compcall.actual); - q->value.compcall.tbp = p->value.compcall.tbp; - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - q->value.constructor = gfc_copy_constructor (p->value.constructor); - break; - - case EXPR_VARIABLE: - case EXPR_NULL: - break; - } - - q->shape = gfc_copy_shape (p->shape, p->rank); - - q->ref = gfc_copy_ref (p->ref); - - return q; -} - - /* Return the maximum kind of two expressions. In general, higher kind numbers mean more precision for numeric types. */ @@ -589,48 +798,6 @@ gfc_numeric_ts (gfc_typespec *ts) } -/* Returns an expression node that is an integer constant. */ - -gfc_expr * -gfc_int_expr (int i) -{ - gfc_expr *p; - - p = gfc_get_expr (); - - p->expr_type = EXPR_CONSTANT; - p->ts.type = BT_INTEGER; - p->ts.kind = gfc_default_integer_kind; - - p->where = gfc_current_locus; - mpz_init_set_si (p->value.integer, i); - - return p; -} - - -/* Returns an expression node that is a logical constant. */ - -gfc_expr * -gfc_logical_expr (int i, locus *where) -{ - gfc_expr *p; - - p = gfc_get_expr (); - - p->expr_type = EXPR_CONSTANT; - p->ts.type = BT_LOGICAL; - p->ts.kind = gfc_default_logical_kind; - - if (where == NULL) - where = &gfc_current_locus; - p->where = *where; - p->value.logical = i; - - return p; -} - - /* Return an expression node with an optional argument list attached. A variable number of gfc_expr pointers are strung together in an argument list with a NULL pointer terminating the list. */ @@ -764,7 +931,6 @@ gfc_is_constant_expr (gfc_expr *e) { gfc_constructor *c; gfc_actual_arglist *arg; - int rv; if (e == NULL) return 1; @@ -772,68 +938,55 @@ gfc_is_constant_expr (gfc_expr *e) switch (e->expr_type) { case EXPR_OP: - rv = (gfc_is_constant_expr (e->value.op.op1) - && (e->value.op.op2 == NULL - || gfc_is_constant_expr (e->value.op.op2))); - break; + return (gfc_is_constant_expr (e->value.op.op1) + && (e->value.op.op2 == NULL + || gfc_is_constant_expr (e->value.op.op2))); case EXPR_VARIABLE: - rv = 0; - break; + return 0; case EXPR_FUNCTION: case EXPR_PPC: case EXPR_COMPCALL: /* Specification functions are constant. */ if (check_specification_function (e) == MATCH_YES) - { - rv = 1; - break; - } + return 1; /* Call to intrinsic with at least one argument. */ - rv = 0; if (e->value.function.isym && e->value.function.actual) { for (arg = e->value.function.actual; arg; arg = arg->next) - { - if (!gfc_is_constant_expr (arg->expr)) - break; - } - if (arg == NULL) - rv = 1; + if (!gfc_is_constant_expr (arg->expr)) + return 0; + + return 1; } - break; + else + return 0; case EXPR_CONSTANT: case EXPR_NULL: - rv = 1; - break; + return 1; case EXPR_SUBSTRING: - rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) - && gfc_is_constant_expr (e->ref->u.ss.end)); - break; + return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) + && gfc_is_constant_expr (e->ref->u.ss.end)); case EXPR_STRUCTURE: - rv = 0; - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) if (!gfc_is_constant_expr (c->expr)) - break; + return 0; - if (c == NULL) - rv = 1; - break; + return 1; case EXPR_ARRAY: - rv = gfc_constant_ac (e); - break; + return gfc_constant_ac (e); default: gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); + return 0; } - - return rv; } @@ -1005,11 +1158,12 @@ simplify_intrinsic_op (gfc_expr *p, int type) with gfc_simplify_expr(). */ static gfc_try -simplify_constructor (gfc_constructor *c, int type) +simplify_constructor (gfc_constructor_base base, int type) { + gfc_constructor *c; gfc_expr *p; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { if (c->iterator && (gfc_simplify_expr (c->iterator->start, type) == FAILURE @@ -1041,7 +1195,7 @@ simplify_constructor (gfc_constructor *c, int type) /* Pull a single array element out of an array constructor. */ static gfc_try -find_array_element (gfc_constructor *cons, gfc_array_ref *ar, +find_array_element (gfc_constructor_base base, gfc_array_ref *ar, gfc_constructor **rval) { unsigned long nelemen; @@ -1050,6 +1204,7 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar, mpz_t offset; mpz_t span; mpz_t tmp; + gfc_constructor *cons; gfc_expr *e; gfc_try t; @@ -1104,16 +1259,13 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar, mpz_mul (span, span, tmp); } - for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) + for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); + cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) { - if (cons) + if (cons->iterator) { - if (cons->iterator) - { - cons = NULL; - goto depart; - } - cons = cons->next; + cons = NULL; + goto depart; } } @@ -1132,20 +1284,21 @@ depart: /* Find a component of a structure constructor. */ static gfc_constructor * -find_component_ref (gfc_constructor *cons, gfc_ref *ref) +find_component_ref (gfc_constructor_base base, gfc_ref *ref) { gfc_component *comp; gfc_component *pick; + gfc_constructor *c = gfc_constructor_first (base); comp = ref->u.c.sym->components; pick = ref->u.c.component; while (comp != pick) { comp = comp->next; - cons = cons->next; + c = gfc_constructor_next (c); } - return cons; + return c; } @@ -1190,15 +1343,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) mpz_t tmp_mpz; mpz_t nelts; mpz_t ptr; - mpz_t index; - gfc_constructor *cons; - gfc_constructor *base; + gfc_constructor_base base; + gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; gfc_expr *begin; gfc_expr *finish; gfc_expr *step; gfc_expr *upper; gfc_expr *lower; - gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c; gfc_try t; t = SUCCESS; @@ -1240,6 +1391,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ { + gfc_constructor *ci; gcc_assert (begin); if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) @@ -1256,16 +1408,16 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) break; } - vecsub[d] = begin->value.constructor; + vecsub[d] = gfc_constructor_first (begin->value.constructor); mpz_set (ctr[d], vecsub[d]->expr->value.integer); mpz_mul (nelts, nelts, begin->shape[0]); mpz_set (expr->shape[shape_i++], begin->shape[0]); /* Check bounds. */ - for (c = vecsub[d]; c; c = c->next) + for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) { - if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0 - || mpz_cmp (c->expr->value.integer, + if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 + || mpz_cmp (ci->expr->value.integer, lower->value.integer) < 0) { gfc_error ("index in dimension %d is out of bounds " @@ -1346,9 +1498,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) mpz_mul (delta_mpz, delta_mpz, tmp_mpz); } - mpz_init (index); mpz_init (ptr); - cons = base; + cons = gfc_constructor_first (base); /* Now clock through the array reference, calculating the index in the source constructor and transferring the elements to the new @@ -1374,11 +1525,11 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) { gcc_assert(vecsub[d]); - if (!vecsub[d]->next) - vecsub[d] = ref->u.ar.start[d]->value.constructor; + if (!gfc_constructor_next (vecsub[d])) + vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); else { - vecsub[d] = vecsub[d]->next; + vecsub[d] = gfc_constructor_next (vecsub[d]); incr_ctr = false; } mpz_set (ctr[d], vecsub[d]->expr->value.integer); @@ -1396,25 +1547,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) } } - /* There must be a better way of dealing with negative strides - than resetting the index and the constructor pointer! */ - if (mpz_cmp (ptr, index) < 0) - { - mpz_set_ui (index, 0); - cons = base; - } - - while (cons && cons->next && mpz_cmp (ptr, index) > 0) - { - mpz_add_ui (index, index, one); - cons = cons->next; - } - - gfc_append_constructor (expr, gfc_copy_expr (cons->expr)); + cons = gfc_constructor_lookup (base, mpz_get_ui (ptr)); + gcc_assert (cons); + gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (cons->expr), NULL); } mpz_clear (ptr); - mpz_clear (index); cleanup: @@ -1429,7 +1568,7 @@ cleanup: mpz_clear (ctr[d]); mpz_clear (stride[d]); } - gfc_free_constructor (base); + gfc_constructor_free (base); return t; } @@ -1470,7 +1609,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) static gfc_try simplify_const_ref (gfc_expr *p) { - gfc_constructor *cons; + gfc_constructor *cons, *c; gfc_expr *newp; gfc_ref *last_ref; @@ -1510,20 +1649,20 @@ simplify_const_ref (gfc_expr *p) if (p->ref->next != NULL && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED)) { - cons = p->value.constructor; - for (; cons; cons = cons->next) + for (c = gfc_constructor_first (p->value.constructor); + c; c = gfc_constructor_next (c)) { - cons->expr->ref = gfc_copy_ref (p->ref->next); - if (simplify_const_ref (cons->expr) == FAILURE) + c->expr->ref = gfc_copy_ref (p->ref->next); + if (simplify_const_ref (c->expr) == FAILURE) return FAILURE; } if (p->ts.type == BT_DERIVED && p->ref->next - && p->value.constructor) + && (c = gfc_constructor_first (p->value.constructor))) { /* There may have been component references. */ - p->ts = p->value.constructor->expr->ts; + p->ts = c->expr->ts; } last_ref = p->ref; @@ -1537,9 +1676,9 @@ simplify_const_ref (gfc_expr *p) character length according to the first element (as all should have the same length). */ int string_len; - if (p->value.constructor) + if ((c = gfc_constructor_first (p->value.constructor))) { - const gfc_expr* first = p->value.constructor->expr; + const gfc_expr* first = c->expr; gcc_assert (first->expr_type == EXPR_CONSTANT); gcc_assert (first->ts.type == BT_CHARACTER); string_len = first->value.character.length; @@ -1553,7 +1692,9 @@ simplify_const_ref (gfc_expr *p) else gfc_free_expr (p->ts.u.cl->length); - p->ts.u.cl->length = gfc_int_expr (string_len); + p->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, + NULL, string_len); } } gfc_free_ref_list (p->ref); @@ -1724,7 +1865,9 @@ gfc_simplify_expr (gfc_expr *p, int type) p->value.character.string = s; p->value.character.length = end - start; p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - p->ts.u.cl->length = gfc_int_expr (p->value.character.length); + p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, + p->value.character.length); gfc_free_ref_list (p->ref); p->ref = NULL; p->expr_type = EXPR_CONSTANT; @@ -1812,10 +1955,12 @@ static gfc_try scalarize_intrinsic_call (gfc_expr *e) { gfc_actual_arglist *a, *b; - gfc_constructor *args[5], *ctor, *new_ctor; + gfc_constructor_base ctor; + gfc_constructor *args[5]; + gfc_constructor *ci, *new_ctor; gfc_expr *expr, *old; int n, i, rank[5], array_arg; - + /* Find which, if any, arguments are arrays. Assume that the old expression carries the type information and that the first arg that is an array expression carries all the shape information.*/ @@ -1836,9 +1981,8 @@ scalarize_intrinsic_call (gfc_expr *e) old = gfc_copy_expr (e); - gfc_free_constructor (expr->value.constructor); + gfc_constructor_free (expr->value.constructor); expr->value.constructor = NULL; - expr->ts = old->ts; expr->where = old->where; expr->expr_type = EXPR_ARRAY; @@ -1858,7 +2002,7 @@ scalarize_intrinsic_call (gfc_expr *e) { rank[n] = a->expr->rank; ctor = a->expr->symtree->n.sym->value->value.constructor; - args[n] = gfc_copy_constructor (ctor); + args[n] = gfc_constructor_first (ctor); } else if (a->expr && a->expr->expr_type == EXPR_ARRAY) { @@ -1866,10 +2010,12 @@ scalarize_intrinsic_call (gfc_expr *e) rank[n] = a->expr->rank; else rank[n] = 1; - args[n] = gfc_copy_constructor (a->expr->value.constructor); + ctor = gfc_constructor_copy (a->expr->value.constructor); + args[n] = gfc_constructor_first (ctor); } else args[n] = NULL; + n++; } @@ -1877,53 +2023,46 @@ scalarize_intrinsic_call (gfc_expr *e) /* Using the array argument as the master, step through the array calling the function for each element and advancing the array constructors together. */ - ctor = args[array_arg - 1]; - new_ctor = NULL; - for (; ctor; ctor = ctor->next) + for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) { - if (expr->value.constructor == NULL) - expr->value.constructor - = new_ctor = gfc_get_constructor (); + new_ctor = gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (old), NULL); + + gfc_free_actual_arglist (new_ctor->expr->value.function.actual); + a = NULL; + b = old->value.function.actual; + for (i = 0; i < n; i++) + { + if (a == NULL) + new_ctor->expr->value.function.actual + = a = gfc_get_actual_arglist (); else { - new_ctor->next = gfc_get_constructor (); - new_ctor = new_ctor->next; + a->next = gfc_get_actual_arglist (); + a = a->next; } - new_ctor->expr = gfc_copy_expr (old); - gfc_free_actual_arglist (new_ctor->expr->value.function.actual); - a = NULL; - b = old->value.function.actual; - for (i = 0; i < n; i++) - { - if (a == NULL) - new_ctor->expr->value.function.actual - = a = gfc_get_actual_arglist (); - else - { - a->next = gfc_get_actual_arglist (); - a = a->next; - } - if (args[i]) - a->expr = gfc_copy_expr (args[i]->expr); - else - a->expr = gfc_copy_expr (b->expr); - b = b->next; - } + if (args[i]) + a->expr = gfc_copy_expr (args[i]->expr); + else + a->expr = gfc_copy_expr (b->expr); + + 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); @@ -2063,21 +2202,22 @@ not_numeric: static gfc_try check_alloc_comp_init (gfc_expr *e) { - gfc_component *c; + gfc_component *comp; gfc_constructor *ctor; gcc_assert (e->expr_type == EXPR_STRUCTURE); gcc_assert (e->ts.type == BT_DERIVED); - for (c = e->ts.u.derived->components, ctor = e->value.constructor; - c; c = c->next, ctor = ctor->next) + for (comp = e->ts.u.derived->components, + ctor = gfc_constructor_first (e->value.constructor); + comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) { - if (c->attr.allocatable + if (comp->attr.allocatable && ctor->expr->expr_type != EXPR_NULL) { gfc_error("Invalid initialization expression for ALLOCATABLE " "component '%s' in structure constructor at %L", - c->name, &ctor->expr->where); + comp->name, &ctor->expr->where); return FAILURE; } } @@ -3444,45 +3584,38 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) gfc_expr * gfc_default_initializer (gfc_typespec *ts) { - gfc_constructor *tail; gfc_expr *init; - gfc_component *c; + gfc_component *comp; /* See if we have a default initializer. */ - for (c = ts->u.derived->components; c; c = c->next) - if (c->initializer || c->attr.allocatable) + for (comp = ts->u.derived->components; comp; comp = comp->next) + if (comp->initializer || comp->attr.allocatable) break; - if (!c) + if (!comp) return NULL; - /* Build the constructor. */ - init = gfc_get_expr (); - init->expr_type = EXPR_STRUCTURE; + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, + &ts->u.derived->declared_at); init->ts = *ts; - init->where = ts->u.derived->declared_at; - tail = NULL; - for (c = ts->u.derived->components; c; c = c->next) + for (comp = ts->u.derived->components; comp; comp = comp->next) { - if (tail == NULL) - init->value.constructor = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } + gfc_constructor *ctor = gfc_constructor_get(); - if (c->initializer) - tail->expr = gfc_copy_expr (c->initializer); + if (comp->initializer) + ctor->expr = gfc_copy_expr (comp->initializer); - if (c->attr.allocatable) + if (comp->attr.allocatable) { - tail->expr = gfc_get_expr (); - tail->expr->expr_type = EXPR_NULL; - tail->expr->ts = c->ts; + ctor->expr = gfc_get_expr (); + ctor->expr->expr_type = EXPR_NULL; + ctor->expr->ts = comp->ts; } + + gfc_constructor_append (&init->value.constructor, ctor); } + return init; } @@ -3611,7 +3744,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, case EXPR_STRUCTURE: case EXPR_ARRAY: - for (c = expr->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) { if (gfc_traverse_expr (c->expr, sym, func, f)) return true; -- cgit v1.2.1 From ee8fe25b192a17e5fe25bd319ece957517ad39c4 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Wed, 14 Apr 2010 05:16:59 +0000 Subject: 2010-04-14 Jerry DeLisle PR fortran/43747 * constructor.c: Fix typo in comment. * expr.c (find_array_section): Add check for max array limit. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158290 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 700fd10f6fe..92454f6536f 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1332,6 +1332,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) int rank; int d; int shape_i; + int limit; long unsigned one = 1; bool incr_ctr; mpz_t start[GFC_MAX_DIMENSIONS]; @@ -1547,7 +1548,18 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) } } - cons = gfc_constructor_lookup (base, mpz_get_ui (ptr)); + limit = mpz_get_ui (ptr); + if (limit >= gfc_option.flag_max_array_constructor) + { + gfc_error ("The number of elements in the array constructor " + "at %L requires an increase of the allowed %d " + "upper limit. See -fmax-array-constructor " + "option", &expr->where, + gfc_option.flag_max_array_constructor); + return FAILURE; + } + + cons = gfc_constructor_lookup (base, limit); gcc_assert (cons); gfc_constructor_append_expr (&expr->value.constructor, gfc_copy_expr (cons->expr), NULL); -- cgit v1.2.1 From 148aaa7fa6884e257d205df009ea315b6b521c9c Mon Sep 17 00:00:00 2001 From: dfranke Date: Thu, 13 May 2010 14:08:05 +0000 Subject: gcc/fortran/: 2010-05-13 Daniel Franke PR fortran/35779 * intrinsic.c (gfc_init_expr): Renamed to gfc_init_expr_flag. Updated all usages. * expr.c (init_flag): Removed; use gfc_init_expr_flag everywhere. * array.c (match_array_list): Pass on gfc_init_expr_flag when matching iterators. gcc/testsuite/: 2010-05-13 Daniel Franke PR fortran/35779 * gfortran.dg/initialization_25.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159366 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 92454f6536f..8230b46d6a2 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1895,7 +1895,7 @@ gfc_simplify_expr (gfc_expr *p, int type) /* Only substitute array parameter variables if we are in an initialization expression, or we want a subsection. */ if (p->symtree->n.sym->attr.flavor == FL_PARAMETER - && (gfc_init_expr || p->ref + && (gfc_init_expr_flag || p->ref || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) { if (simplify_parameter_variable (p, type) == FAILURE) @@ -2626,11 +2626,11 @@ gfc_reduce_init_expr (gfc_expr *expr) { gfc_try t; - gfc_init_expr = 1; + gfc_init_expr_flag = true; t = gfc_resolve_expr (expr); if (t == SUCCESS) t = check_init_expr (expr); - gfc_init_expr = 0; + gfc_init_expr_flag = false; if (t == FAILURE) return FAILURE; @@ -2648,11 +2648,7 @@ gfc_reduce_init_expr (gfc_expr *expr) /* Match an initialization expression. We work by first matching an - expression, then reducing it to a constant. The reducing it to - constant part requires a global variable to flag the prohibition - of a non-integer exponent in -std=f95 mode. */ - -bool init_flag = false; + expression, then reducing it to a constant. */ match gfc_match_init_expr (gfc_expr **result) @@ -2663,12 +2659,12 @@ gfc_match_init_expr (gfc_expr **result) expr = NULL; - init_flag = true; + gfc_init_expr_flag = true; m = gfc_match_expr (&expr); if (m != MATCH_YES) { - init_flag = false; + gfc_init_expr_flag = false; return m; } @@ -2676,12 +2672,12 @@ gfc_match_init_expr (gfc_expr **result) if (t != SUCCESS) { gfc_free_expr (expr); - init_flag = false; + gfc_init_expr_flag = false; return MATCH_ERROR; } *result = expr; - init_flag = false; + gfc_init_expr_flag = false; return MATCH_YES; } -- cgit v1.2.1 From bcc41e511c80b8b8aa549a438ffcac69481db979 Mon Sep 17 00:00:00 2001 From: janus Date: Sat, 15 May 2010 13:52:33 +0000 Subject: 2010-05-15 Janus Weil PR fortran/43207 PR fortran/43969 * gfortran.h (gfc_class_null_initializer): New prototype. * expr.c (gfc_class_null_initializer): New function to build a NULL initializer for CLASS pointers. * symbol.c (gfc_build_class_symbol): Modify internal naming of class containers. Remove default NULL initialization of $data component. * trans.c (gfc_allocate_array_with_status): Fix wording of an error message. * trans-expr.c (gfc_conv_initializer,gfc_trans_subcomponent_assign): Use new function 'gfc_class_null_initializer'. * trans-intrinsic.c (gfc_conv_allocated): Handle allocatable scalar class variables. 2010-05-15 Janus Weil PR fortran/43207 PR fortran/43969 * gfortran.dg/class_18.f03: New. * gfortran.dg/class_19.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159431 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 8230b46d6a2..382d1fe6452 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3628,6 +3628,32 @@ gfc_default_initializer (gfc_typespec *ts) } +/* Build a NULL initializer for CLASS pointers, + initializing the $data and $vptr components to zero. */ + +gfc_expr * +gfc_class_null_initializer (gfc_typespec *ts) +{ + gfc_expr *init; + gfc_component *comp; + + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, + &ts->u.derived->declared_at); + init->ts = *ts; + + for (comp = ts->u.derived->components; comp; comp = comp->next) + { + gfc_constructor *ctor = gfc_constructor_get(); + 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; +} + + /* Given a symbol, create an expression node with that symbol as a variable. If the symbol is array valued, setup a reference of the whole array. */ -- cgit v1.2.1 From b823b0c64afba9f22c659014d67843f440f886db Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 17 May 2010 18:45:32 +0000 Subject: 2010-05-17 Janus Weil * class.c (gfc_add_component_ref,gfc_class_null_initializer, gfc_build_class_symbol,add_proc_component,add_proc_comps, add_procs_to_declared_vtab1,copy_vtab_proc_comps, add_procs_to_declared_vtab,add_generic_specifics, add_generics_to_declared_vtab,gfc_find_derived_vtab, find_typebound_proc_uop,gfc_find_typebound_proc, gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, gfc_get_tbp_symtree): Moved here from other places. * expr.c (gfc_add_component_ref,gfc_class_null_initializer): Move to class.c. * gfortran.h (gfc_build_class_symbol,gfc_find_derived_vtab, gfc_find_typebound_proc,gfc_find_typebound_user_op, gfc_find_typebound_intrinsic_op,gfc_get_tbp_symtree, gfc_add_component_ref, gfc_class_null_initializer): Moved to class.c. * Make-lang.in: Add class.o. * symbol.c (gfc_build_class_symbol,add_proc_component,add_proc_comps, add_procs_to_declared_vtab1,copy_vtab_proc_comps, add_procs_to_declared_vtab,add_generic_specifics, add_generics_to_declared_vtab,gfc_find_derived_vtab, find_typebound_proc_uop,gfc_find_typebound_proc, gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, gfc_get_tbp_symtree): Move to class.c. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159506 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 56 ------------------------------------------------------ 1 file changed, 56 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 382d1fe6452..75f27be80ee 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -676,36 +676,6 @@ gfc_has_vector_index (gfc_expr *e) } -/* Insert a reference to the component of the given name. - Only to be used with CLASS containers. */ - -void -gfc_add_component_ref (gfc_expr *e, const char *name) -{ - gfc_ref **tail = &(e->ref); - gfc_ref *next = NULL; - gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; - while (*tail != NULL) - { - if ((*tail)->type == REF_COMPONENT) - derived = (*tail)->u.c.component->ts.u.derived; - if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) - break; - tail = &((*tail)->next); - } - if (*tail != NULL && strcmp (name, "$data") == 0) - next = *tail; - (*tail) = gfc_get_ref(); - (*tail)->next = next; - (*tail)->type = REF_COMPONENT; - (*tail)->u.c.sym = derived; - (*tail)->u.c.component = gfc_find_component (derived, name, true, true); - gcc_assert((*tail)->u.c.component); - if (!next) - e->ts = (*tail)->u.c.component->ts; -} - - /* Copy a shape array. */ mpz_t * @@ -3628,32 +3598,6 @@ gfc_default_initializer (gfc_typespec *ts) } -/* Build a NULL initializer for CLASS pointers, - initializing the $data and $vptr components to zero. */ - -gfc_expr * -gfc_class_null_initializer (gfc_typespec *ts) -{ - gfc_expr *init; - gfc_component *comp; - - init = gfc_get_structure_constructor_expr (ts->type, ts->kind, - &ts->u.derived->declared_at); - init->ts = *ts; - - for (comp = ts->u.derived->components; comp; comp = comp->next) - { - gfc_constructor *ctor = gfc_constructor_get(); - 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; -} - - /* Given a symbol, create an expression node with that symbol as a variable. If the symbol is array valued, setup a reference of the whole array. */ -- cgit v1.2.1 From 0826251092361171d72575cd36d4578e22cf9e9e Mon Sep 17 00:00:00 2001 From: dfranke Date: Wed, 19 May 2010 13:07:25 +0000 Subject: gcc/fortran/: 2010-05-19 Daniel Franke PR fortran/42360 * gfortran.h (gfc_has_default_initializer): New. * expr.c (gfc_has_default_initializer): New. * resolve.c (has_default_initializer): Removed, use gfc_has_default_initializer() instead. Updated all callers. * trans-array.c (has_default_initializer): Removed, use gfc_has_default_initializer() instead. Updated all callers. * trans-decl.c (generate_local_decl): Do not check the first component only to check for initializers, but use gfc_has_default_initializer() instead. gcc/testsuite/: 2010-05-19 Daniel Franke PR fortran/42360 * gfortran.dg/warn_intent_out_not_set.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159562 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 75f27be80ee..6884c900186 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3557,6 +3557,31 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) } +/* Check for default initializer; sym->value is not enough + as it is also set for EXPR_NULL of allocatables. */ + +bool +gfc_has_default_initializer (gfc_symbol *der) +{ + gfc_component *c; + + gcc_assert (der->attr.flavor == FL_DERIVED); + for (c = der->components; c; c = c->next) + if (c->ts.type == BT_DERIVED) + { + if (!c->attr.pointer + && gfc_has_default_initializer (c->ts.u.derived)) + return true; + } + else + { + if (c->initializer) + return true; + } + + return false; +} + /* Get an expression for a default initializer. */ gfc_expr * @@ -3565,7 +3590,8 @@ gfc_default_initializer (gfc_typespec *ts) gfc_expr *init; gfc_component *comp; - /* See if we have a default initializer. */ + /* See if we have a default initializer in this, but not in nested + types (otherwise we could use gfc_has_default_initializer()). */ for (comp = ts->u.derived->components; comp; comp = comp->next) if (comp->initializer || comp->attr.allocatable) break; -- cgit v1.2.1 From 50b4b37ba4128b5e02d6b8af5f872770063c1d2b Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 30 May 2010 21:56:11 +0000 Subject: 2010-05-30 Janus Weil * gcc/fortran/gfortran.h (CLASS_DATA): New macro for accessing the $data component of a class container. * gcc/fortran/decl.c (attr_decl1): Use macro CLASS_DATA. * gcc/fortran/expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol, gfc_has_ultimate_allocatable,gfc_has_ultimate_pointer): Ditto. * gcc/fortran/interface.c (matching_typebound_op): Ditto. * gcc/fortran/match.c (gfc_match_allocate, gfc_match_deallocate): Ditto. * gcc/fortran/parse.c (parse_derived): Ditto. * gcc/fortran/primary.c (gfc_match_varspec, gfc_variable_attr, gfc_expr_attr): Ditto. * gcc/fortran/resolve.c (resolve_structure_cons, find_array_spec, resolve_deallocate_expr, resolve_allocate_expr, resolve_select_type, resolve_fl_var_and_proc, resolve_typebound_procedure, resolve_fl_derived): Ditto. * gcc/fortran/symbol.c (gfc_type_compatible): Restructured. * gcc/fortran/trans-array.c (structure_alloc_comps): Use macro CLASS_DATA. * gcc/fortran/trans-decl.c (gfc_get_symbol_decl, gfc_trans_deferred_vars): Ditto. * gcc/fortran/trans-stmt.c (gfc_trans_allocate): Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160060 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 6884c900186..b6452054b11 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3306,8 +3306,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } if (!pointer && !proc_pointer - && !(lvalue->ts.type == BT_CLASS - && lvalue->ts.u.derived->components->attr.pointer)) + && !(lvalue->ts.type == BT_CLASS && CLASS_DATA (lvalue)->attr.pointer)) { gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); return FAILURE; @@ -3544,8 +3543,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) lvalue.where = sym->declared_at; if (sym->attr.pointer || sym->attr.proc_pointer - || (sym->ts.type == BT_CLASS - && sym->ts.u.derived->components->attr.pointer + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.pointer && rvalue->expr_type == EXPR_NULL)) r = gfc_check_pointer_assign (&lvalue, rvalue); else @@ -4039,14 +4037,14 @@ gfc_has_ultimate_allocatable (gfc_expr *e) last = ref; if (last && last->u.c.component->ts.type == BT_CLASS) - return last->u.c.component->ts.u.derived->components->attr.alloc_comp; + return CLASS_DATA (last->u.c.component)->attr.alloc_comp; else if (last && last->u.c.component->ts.type == BT_DERIVED) return last->u.c.component->ts.u.derived->attr.alloc_comp; else if (last) return false; if (e->ts.type == BT_CLASS) - return e->ts.u.derived->components->attr.alloc_comp; + return CLASS_DATA (e)->attr.alloc_comp; else if (e->ts.type == BT_DERIVED) return e->ts.u.derived->attr.alloc_comp; else @@ -4069,14 +4067,14 @@ gfc_has_ultimate_pointer (gfc_expr *e) last = ref; if (last && last->u.c.component->ts.type == BT_CLASS) - return last->u.c.component->ts.u.derived->components->attr.pointer_comp; + return CLASS_DATA (last->u.c.component)->attr.pointer_comp; else if (last && last->u.c.component->ts.type == BT_DERIVED) return last->u.c.component->ts.u.derived->attr.pointer_comp; else if (last) return false; if (e->ts.type == BT_CLASS) - return e->ts.u.derived->components->attr.pointer_comp; + return CLASS_DATA (e)->attr.pointer_comp; else if (e->ts.type == BT_DERIVED) return e->ts.u.derived->attr.pointer_comp; else -- cgit v1.2.1 From b3c3927c05d8ad190b76c56ae6020e1650b85a97 Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 21 Jun 2010 14:15:56 +0000 Subject: 2010-06-20 Tobias Burnus PR fortran/40632 * interface.c (compare_parameter): Add gfc_is_simply_contiguous checks. * symbol.c (gfc_add_contiguous): New function. (gfc_copy_attr, check_conflict): Handle contiguous attribute. * decl.c (match_attr_spec): Ditto. (gfc_match_contiguous): New function. * resolve.c (resolve_fl_derived, resolve_symbol): Handle contiguous. * gfortran.h (symbol_attribute): Add contiguous. (gfc_is_simply_contiguous): Add prototype. (gfc_add_contiguous): Add prototype. * match.h (gfc_match_contiguous): Add prototype. * parse.c (decode_specification_statement, decode_statement): Handle contiguous attribute. * expr.c (gfc_is_simply_contiguous): New function. * dump-parse-tree.c (show_attr): Handle contiguous. * module.c (ab_attribute, attr_bits, mio_symbol_attribute): Ditto. * trans-expr.c (gfc_add_interface_mapping): Copy attr.contiguous. * trans-array.c (gfc_conv_descriptor_stride_get, gfc_conv_array_parameter): Handle contiguous arrays. * trans-types.c (gfc_build_array_type, gfc_build_array_type, gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info): Ditto. * trans.h (gfc_array_kind): Ditto. * trans-decl.c (gfc_get_symbol_decl): Ditto. 2010-06-20 Tobias Burnus PR fortran/40632 * gfortran.dg/contiguous_1.f90: New. * gfortran.dg/contiguous_2.f90: New. * gfortran.dg/contiguous_3.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161079 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 102 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 102 insertions(+) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index b6452054b11..c876fdd7740 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4080,3 +4080,105 @@ gfc_has_ultimate_pointer (gfc_expr *e) else return false; } + + +/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. + Note: A scalar is not regarded as "simply contiguous" by the standard. + if bool is not strict, some futher checks are done - for instance, + a "(::1)" is accepted. */ + +bool +gfc_is_simply_contiguous (gfc_expr *expr, bool strict) +{ + bool colon; + int i; + gfc_array_ref *ar = NULL; + gfc_ref *ref, *part_ref = NULL; + + if (expr->expr_type == EXPR_FUNCTION) + return expr->value.function.esym + ? expr->value.function.esym->result->attr.contiguous : false; + else if (expr->expr_type != EXPR_VARIABLE) + return false; + + if (expr->rank == 0) + return false; + + for (ref = expr->ref; ref; ref = ref->next) + { + if (ar) + return false; /* Array shall be last part-ref. */ + + if (ref->type == REF_COMPONENT) + part_ref = ref; + else if (ref->type == REF_SUBSTRING) + return false; + else if (ref->u.ar.type != AR_ELEMENT) + ar = &ref->u.ar; + } + + if ((part_ref && !part_ref->u.c.component->attr.contiguous + && part_ref->u.c.component->attr.pointer) + || (!part_ref && !expr->symtree->n.sym->attr.contiguous + && (expr->symtree->n.sym->attr.pointer + || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE))) + return false; + + if (!ar || ar->type == AR_FULL) + return true; + + gcc_assert (ar->type == AR_SECTION); + + /* Check for simply contiguous array */ + colon = true; + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_VECTOR) + return false; + + if (ar->dimen_type[i] == DIMEN_ELEMENT) + { + colon = false; + continue; + } + + gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); + + + /* If the previous section was not contiguous, that's an error, + unless we have effective only one element and checking is not + strict. */ + if (!colon && (strict || !ar->start[i] || !ar->end[i] + || ar->start[i]->expr_type != EXPR_CONSTANT + || ar->end[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->end[i]->value.integer) != 0)) + return false; + + /* Following the standard, "(::1)" or - if known at compile time - + "(lbound:ubound)" are not simply contigous; if strict + is false, they are regarded as simply contiguous. */ + if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT + || ar->stride[i]->ts.type != BT_INTEGER + || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) + return false; + + if (ar->start[i] + && (strict || ar->start[i]->expr_type != EXPR_CONSTANT + || !ar->as->lower[i] + || ar->as->lower[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->as->lower[i]->value.integer) != 0)) + colon = false; + + if (ar->end[i] + && (strict || ar->end[i]->expr_type != EXPR_CONSTANT + || !ar->as->upper[i] + || ar->as->upper[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->end[i]->value.integer, + ar->as->upper[i]->value.integer) != 0)) + colon = false; + } + + return true; +} -- cgit v1.2.1 From 58b069a099182c5367587d098eda613ee3947fec Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 6 Jul 2010 20:56:07 +0000 Subject: 2010-07-06 Tobias Burnus PR fortran/44742 * array.c (gfc_expand_constructor): Add optional diagnostic. * gfortran.h (gfc_expand_constructor): Update prototype. * expr.c (gfc_simplify_expr, check_init_expr, gfc_reduce_init_expr): Update gfc_expand_constructor call. * resolve.c (gfc_resolve_expr): Ditto. 2010-07-06 Tobias Burnus PR fortran/44742 * gfortran.dg/parameter_array_init_6.f90: New. * gfortran.dg/initialization_20.f90: Update dg-error. * gfortran.dg/initialization_24.f90: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161888 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index c876fdd7740..12a46a9cbed 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1894,7 +1894,7 @@ gfc_simplify_expr (gfc_expr *p, int type) if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY && p->ref->u.ar.type == AR_FULL) - gfc_expand_constructor (p); + gfc_expand_constructor (p, false); if (simplify_const_ref (p) == FAILURE) return FAILURE; @@ -2573,7 +2573,7 @@ check_init_expr (gfc_expr *e) if (t == FAILURE) break; - t = gfc_expand_constructor (e); + t = gfc_expand_constructor (e, true); if (t == FAILURE) break; @@ -2609,7 +2609,7 @@ gfc_reduce_init_expr (gfc_expr *expr) { if (gfc_check_constructor_type (expr) == FAILURE) return FAILURE; - if (gfc_expand_constructor (expr) == FAILURE) + if (gfc_expand_constructor (expr, true) == FAILURE) return FAILURE; } -- cgit v1.2.1 From 1da1826b7789821567dedb4a5418c6d61c915d1c Mon Sep 17 00:00:00 2001 From: burnus Date: Thu, 8 Jul 2010 15:17:25 +0000 Subject: 2010-07-08 Tobias Burnus PR fortran/18918 * array.c (gfc_match_array_ref): Better error message for coarrays with too few ranks. (match_subscript): Move one diagnostic to caller. * gfortran.h (gfc_get_corank): Add prottype. * expr.c (gfc_get_corank): New function. * iresolve.c (resolve_bound): Fix rank for cobounds. (gfc_resolve_lbound,gfc_resolve_lcobound, gfc_resolve_ubound, gfc_resolve_ucobound, gfc_resolve_this_image): Update resolve_bound call. 2010-07-08 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_10.f90: Add an additional test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161960 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 12a46a9cbed..acbec8dcabc 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4022,6 +4022,22 @@ gfc_is_coindexed (gfc_expr *e) } +bool +gfc_get_corank (gfc_expr *e) +{ + int corank; + gfc_ref *ref; + corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + corank = ref->u.ar.as->corank; + gcc_assert (ref->type != REF_SUBSTRING); + } + return corank; +} + + /* Check whether the expression has an ultimate allocatable component. Being itself allocatable does not count. */ bool -- cgit v1.2.1 From a33fbb6f8853e5ec06f3ec241af9f5e91bd4e1c3 Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 11 Jul 2010 07:55:11 +0000 Subject: 2010-07-11 Janus Weil PR fortran/44689 * decl.c (build_sym,attr_decl1): Only build the class container if the symbol has sufficient attributes. * expr.c (gfc_check_pointer_assign): Use class_pointer instead of pointer attribute for classes. * match.c (gfc_match_allocate,gfc_match_deallocate): Ditto. * module.c (MOD_VERSION): Bump. (enum ab_attribute,attr_bits): Add AB_CLASS_POINTER. (mio_symbol_attribute): Handle class_pointer attribute. * parse.c (parse_derived): Use class_pointer instead of pointer attribute for classes. * primary.c (gfc_variable_attr,gfc_expr_attr): Ditto. * resolve.c (resolve_structure_cons,resolve_deallocate_expr, resolve_allocate_expr,resolve_fl_derived): Ditto. (resolve_fl_var_and_proc): Check for class_ok attribute. 2010-07-11 Janus Weil PR fortran/44689 * gfortran.dg/class_24.f03: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162052 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index acbec8dcabc..39fc7493264 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3306,7 +3306,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } if (!pointer && !proc_pointer - && !(lvalue->ts.type == BT_CLASS && CLASS_DATA (lvalue)->attr.pointer)) + && !(lvalue->ts.type == BT_CLASS + && CLASS_DATA (lvalue)->attr.class_pointer)) { gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); return FAILURE; @@ -3543,7 +3544,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) lvalue.where = sym->declared_at; if (sym->attr.pointer || sym->attr.proc_pointer - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.pointer + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer && rvalue->expr_type == EXPR_NULL)) r = gfc_check_pointer_assign (&lvalue, rvalue); else -- cgit v1.2.1 From 417c9c5c12f60741c2984609d91f0c45cb302489 Mon Sep 17 00:00:00 2001 From: mikael Date: Mon, 12 Jul 2010 14:31:00 +0000 Subject: 2010-07-12 Mikael Morin * expr.c (gfc_get_int_expr): Don't initialize mpfr data twice. * resolve.c (build_default_init_expr): Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162081 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/fortran/expr.c') diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 39fc7493264..cb7305ecf5a 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -215,7 +215,7 @@ gfc_get_int_expr (int kind, locus *where, int value) p = gfc_get_constant_expr (BT_INTEGER, kind, where ? where : &gfc_current_locus); - mpz_init_set_si (p->value.integer, value); + mpz_set_si (p->value.integer, value); return p; } -- cgit v1.2.1