diff options
| author | Daniel Berlin <dberlin@dberlin.org> | 2005-02-28 03:48:13 +0000 |
|---|---|---|
| committer | Daniel Berlin <dberlin@dberlin.org> | 2005-02-28 03:48:13 +0000 |
| commit | ff5f58a960ef5ebef296b78380ac21ec73eb60d3 (patch) | |
| tree | 6b416e8523c502a82d386c98de1a39da6527b040 /gcc/fortran | |
| parent | f9f5c9e8498b005d223e54abc259d8edc19f22f3 (diff) | |
Merge from the pain trainstructure-aliasing-branch
git-svn-id: https://gcc.gnu.org/svn/gcc/branches/structure-aliasing-branch@95649 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran')
31 files changed, 777 insertions, 508 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 707ab1b8631..846186a3174 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,218 @@ +2005-02-24 Volker Reichelt <reichelt@igpm.rwth-aachen.de> + + * decl.c, resolve.c, trans-array.c, trans.h: Fix comment typo(s). + +2005-02-24 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + Revert yesterday's patch: + 2005-02-23 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * gfortran.h (gfc_component, gfc_actual_arglist, ... + ... argument. Copy string instead of pointing to it. + +2005-02-23 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * gfortran.h (gfc_get_namespace): Add second argument to prototype. + * intrinsic.c (gfc_intrinsic_init_1): Pass second argument to + gfc_get_namespace. + * module.c (mio_namespace_ref, load_needed): Likewise. + * parse.c (parse_interface, parse_contained): Likewise. Here the + correct second argument matters. + * symbol.c (gfc_get_namespace): Add parent_types argument, only copy + parent's implicit types if this is set. + (gfc_symbol_init_2): Pass second argument to gfc_get_namespace. + * trans-common.c (build_common_decl): Likewise. + + * gfortran.h (symbol_attribute): New 'untyped' field, fix comment + formatting. + * symbol.c (gfc_set_default_type): Issue error only once, by setting + and checking 'untyped' attribute. + + * gfortran.h (gfc_expr): Move 'operator', 'op1', 'op2', and 'uop' + fields into new struct 'op' inside the 'value' union. + * arith.c (eval_intrinsic): Adapt all users. + * dependency.c (gfc_check_dependency): Likewise. + * dump-parse-tree.c (gfc_show_expr): Likewise. + * expr.c (gfc_get_expr): Don't clear removed fields. + (free_expr0, gfc_copy_expr, gfc_type_convert_binary, + gfc_is_constant_expr, simplify_intrinsic_op, check_init_expr, + check_intrinsic_op): Adapt to new field names. + * interface.c (gfc_extend_expr): Likewise. Also explicitly + nullify 'esym' and 'isym' fields of new function call. + * iresolve.c (gfc_resolve_dot_product, gfc_resolve_matmul): + Adapt to renamed structure fields. + * matchexp.c (build_node, match_level_1, match_expr): Likewise. + * module.c (mio_expr): Likewise. + * resolve.c (resolve_operator): Likewise. + (gfc_find_forall_index): Likewise. Only look through operands + if dealing with EXPR_OP + * trans-array.c (gfc_walk_op_expr): Adapt to renamed fields. + * trans-expr.c (gfc_conv_unary_op, gfc_conv_power_op, + gfc_conv_concat_op, gfc_conv_expr_op): Likewise. + + [ Reverted ] + * gfortran.h (gfc_component, gfc_actual_arglist, gfc_user_op): Make + 'name' a 'const char *'. + (gfc_symbol): Likewise, also for 'module'. + (gfc_symtree): Make 'name' a 'const char *'. + (gfc_intrinsic_sym): Likewise, also for 'lib_name'. + (gfc_get_gsymbol, gfc_find_gsymbol): Add 'const' qualifier to + 'char *' argument. + (gfc_intrinsic_symbol): Use 'gfc_get_string' instead of 'strcpy' to + initialize 'SYM->module'. + * check.c (gfc_check_minloc_maxloc, check_reduction): Check for NULL + pointer instead of empty string. + * dump-parse-tree.c (gfc_show_actual_arglist): Likewise. + * interface.c (gfc_compare_types): Adapt check to account for possible + NULL pointer. + (compare_actual_formal): Check for NULL pointer instead of empty + string. + * intrinsic.c (gfc_current_intrinsic, gfc_current_intrinsic_arg): + Add 'const' qualifier. + (conv_name): Return a heap allocated string. + (find_conv): Add 'const' qualifier to 'target'. + (add_sym): Use 'gfc_get_string' instead of 'strcpy'. + (make_generic): Check for NULL pointer instead of empty string. + (make_alias): Use 'gfc_get_string' instead of 'strcpy'. + (add_conv): No need to strcpy result from 'conv_name'. + (sort_actual): Check for NULL pointer instead of empty string. + * intrinsic.h (gfc_current_intrinsic, gfc_current_intrinsic_arg): + Adapt prototype. + * module.c (compare_true_names): Compare pointers instead of strings + for 'module' member. + (find_true_name): Initialize string fields with gfc_get_string. + (mio_pool_string): New function. + (mio_internal_string): Adapt comment. + (mio_component_ref, mio_component, mio_actual_arg): Use + 'mio_pool_string' instead of 'mio_internal_string'. + (mio_symbol_interface): Add 'const' qualifier to string arguments. + Add level of indirection. Use 'mio_pool_string' instead of + 'mio_internal_string'. + (load_needed, read_module): Use 'gfc_get_string' instead of 'strcpy'. + (write_common, write_symbol): Use 'mio_pool_string' instead of + 'mio_internal_string'. + (write_symbol0, write_symbol1): Likewise, also check for NULL pointer + instead of empty string. + (write_operator, write_generic): Pass correct type variable to + 'mio_symbol_interface'. + (write_symtree): Use 'mio_pool_string' instead of + 'mio_internal_string'. + * primary.c (match_keyword_arg): Adapt check to possible + case of NULL pointer. Use 'gfc_get_string' instead of 'strcpy'. + * symbol.c (gfc_add_component, gfc_new_symtree, delete_symtree, + gfc_get_uop, gfc_new_symbol): Use 'gfc_get_string' instead of + 'strcpy'. + (ambiguous_symbol): Check for NULL pointer instead of empty string. + (gfc_find_gsymbol, gfc_get_gsymbol): Add 'const' qualifier on string + arguments. + * trans-array.c (gfc_trans_auto_array_allocation): Check for NULL + pointer instead of empty string. + * trans-decl.c (gfc_sym_mangled_identifier, + gfc_sym_mangled_function_id, gfc_finish_var_decl, gfc_get_symbol_decl, + gfc_get_symbol_decl): Likewise. + * trans-io.c (gfc_new_nml_name_expr): Add 'const' qualifier to + argument. Copy string instead of pointing to it. + +2005-02-23 Kazu Hirata <kazu@cs.umass.edu> + + * intrinsic.h, st.c: Update copyright. + +2005-02-20 Steven G. Kargl <kargls@comcast.net> + + * symbol.c: Typos in comments. + +2005-02-20 Steven G. Kargl <kargls@comcast.net> + + * expr.c (gfc_type_convert_binary): Typo in comment. + +2005-02-19 Steven G. Kargl <kargls@comcast.net> + + * check.c (gfc_check_selected_int_kind): New function. + * intrinsic.h: Prototype it. + * intrinsic.c (add_function): Use it. + * simplify (gfc_simplify_ceiling,gfc_simplify_floor): Change + BT_REAL to BT_INTEGER and use gfc_default_integer_kind. + +2005-02-19 Steven G. Kargl <kargls@comcast.net> + + * check.c (gfc_check_int): improve checking of optional kind + * simplify.c (gfc_simplify_int): Change BT_REAL to BT_INTEGER + +2005-02-19 Steven G. Kargl <kargls@comcast.net> + + * check.c (gfc_check_achar): New function + * intrinsic.h: Prototype it. + * intrinsic.c (add_function): Use it. + +2005-02-13 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * trans-stmt.c (generate_loop_for_temp_to_lhs, + generate_loop_for_rhs_to_temp): Remove if whose condition is + always true. + +2005-02-12 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * symbol.c (gfc_use_ha_derived): Remove, fold functionality into ... + (gfc_use_derived): ... this function. + +2005-02-09 Richard Henderson <rth@redhat.com> + + * f95-lang.c (gfc_init_builtin_functions): Call + build_common_builtin_nodes; do not define any functions handled + by it. + +2005-02-08 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * expr.c (gfc_copy_expr): Don't copy 'op1' and 'op2' for + EXPR_SUBSTRING. + (gfc_is_constant_expr): Check 'ref' to determine if substring + reference is constant. + (gfc_simplify_expr): Simplify 'ref' instead of 'op1' and 'op2'. + (check_init_expr, check_restricted): Check 'ref' instead of 'op1' + and 'op2'. + * module.c (mio_expr): Read / write 'ref' instead of 'op1' and 'op2'. + +2005-02-07 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de> + + * gfortran.h (gfc_add_dimension, gfc_add_result, gfc_add_save, + gfc_add_dummy, gfc_add_generic, gfc_add_in_common, gfc_add_data, + gfc_add_in_namelist, gfc_add_sequence, gfc_add_function, + gfc_add_subroutine, gfc_add_access, gfc_add_flavor, gfc_add_entry, + gfc_add_procedure): Add argument. + * array.c (gfc_set_array_spec), decl.c (var_element, get_proc_name, + gfc_match_null, match_type_spec, match_attr_spec, + gfc_match_formal_arglist, match_result, gfc_match_function_decl): + Update callers to match. + (gfc_match_entry) : Likewise, fix comment typo. + (gfc_match_subroutine, attr_decl1, gfc_add_dimension, + access_attr_decl, do_parm, gfc_match_save, gfc_match_modproc, + gfc_match_derived_decl): Update callers. + * interface.c (gfc_match_interface): Likewise. + * match.c (gfc_match_label, gfc_add_flavor, + gfc_match_call, gfc_match_common, gfc_match_block_data, + gfc_match_namelist, gfc_match_module, gfc_match_st_function): + Likewise. + * parse.c (parse_derived, parse_interface, parse_contained), + primary.c (gfc_match_rvalue, gfc_match_variable): Likewise. + * resolve.c (resolve_formal_arglist, resolve_entries): Update callers. + * symbol.c (check_conflict, check_used): Add new 'name' argument, + use when printing error message. + (gfc_add_dimension, gfc_add_result, gfc_add_save, gfc_add_dummy, + gfc_add_generic, gfc_add_in_common, gfc_add_data, + gfc_add_in_namelist, gfc_add_sequence, gfc_add_function, + gfc_add_subroutine, gfc_add_access, gfc_add_flavor, gfc_add_entry, + gfc_add_procedure): Add new 'name' argument. Pass along to + check_conflict and check_used. + (gfc_add_allocatable, gfc_add_external, gfc_add_intrinsic, + gfc_add_optional, gfc_add_pointer, gfc_add_target, gfc_add_elemental, + gfc_add_pure, gfc_add_recursive, gfc_add_intent, + gfc_add_explicit_interface, gfc_copy_attr): Pass NULL for new + argument in calls to any of the modified functions. + +2005-02-06 Joseph S. Myers <joseph@codesourcery.com> + + * gfortran.texi: Don't give last update date. + 2006-01-30 Richard Henderson <rth@redhat.com> * options.c (gfc_init_options): Zero flag_errno_math. diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 924eea0fb2f..a219ed20675 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -1598,10 +1598,10 @@ eval_intrinsic (gfc_intrinsic_op operator, temp.expr_type = EXPR_OP; gfc_clear_ts (&temp.ts); - temp.operator = operator; + temp.value.op.operator = operator; - temp.op1 = op1; - temp.op2 = op2; + temp.value.op.op1 = op1; + temp.value.op.op2 = op2; gfc_type_convert_binary (&temp); @@ -1671,10 +1671,10 @@ runtime: result->ts = temp.ts; result->expr_type = EXPR_OP; - result->operator = operator; + result->value.op.operator = operator; - result->op1 = op1; - result->op2 = op2; + result->value.op.op1 = op1; + result->value.op.op2 = op2; result->where = op1->where; diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index c09bf8bcce5..4f4f19b100b 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -457,7 +457,7 @@ gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc) if (as == NULL) return SUCCESS; - if (gfc_add_dimension (&sym->attr, error_loc) == FAILURE) + if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE) return FAILURE; sym->as = as; diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index a63112bd81e..7a971f20038 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -401,6 +401,16 @@ gfc_check_abs (gfc_expr * a) return SUCCESS; } +try +gfc_check_achar (gfc_expr * a) +{ + + if (type_check (a, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + try gfc_check_all_any (gfc_expr * mask, gfc_expr * dim) @@ -936,10 +946,18 @@ gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back) try gfc_check_int (gfc_expr * x, gfc_expr * kind) { - if (numeric_check (x, 0) == FAILURE - || kind_check (kind, 1, BT_INTEGER) == FAILURE) + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + if (kind != NULL) + { + if (type_check (kind, 1, BT_INTEGER) == FAILURE) return FAILURE; + if (scalar_check (kind, 1) == FAILURE) + return FAILURE; + } + return SUCCESS; } @@ -1196,7 +1214,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap) m = ap->next->next->expr; if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL - && ap->next->name[0] == '\0') + && ap->next->name == NULL) { m = d; d = NULL; @@ -1241,7 +1259,7 @@ check_reduction (gfc_actual_arglist * ap) m = ap->next->next->expr; if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL - && ap->next->name[0] == '\0') + && ap->next->name == NULL) { m = d; d = NULL; @@ -1536,6 +1554,20 @@ gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z) try +gfc_check_selected_int_kind (gfc_expr * r) +{ + + if (type_check (r, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (r, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r) { if (p == NULL && r == NULL) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 92326e7066a..b3114cac2c1 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -27,7 +27,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include "parse.h" -/* This flag is set if a an old-style length selector is matched +/* This flag is set if an old-style length selector is matched during a type-declaration statement. */ static int old_char_selector; @@ -198,7 +198,7 @@ var_element (gfc_data_variable * new) } #endif - if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE) + if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE) return MATCH_ERROR; return MATCH_YES; @@ -598,7 +598,8 @@ get_proc_name (const char *name, gfc_symbol ** result) if (sym->ns->proc_name != NULL && sym->ns->proc_name->attr.flavor == FL_MODULE && sym->attr.proc != PROC_MODULE - && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE) + && gfc_add_procedure (&sym->attr, PROC_MODULE, + sym->name, NULL) == FAILURE) rc = 2; return rc; @@ -818,8 +819,9 @@ gfc_match_null (gfc_expr ** result) gfc_intrinsic_symbol (sym); if (sym->attr.proc != PROC_INTRINSIC - && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, NULL) == FAILURE - || gfc_add_function (&sym->attr, NULL) == FAILURE)) + && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, + sym->name, NULL) == FAILURE + || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)) return MATCH_ERROR; e = gfc_get_expr (); @@ -1369,7 +1371,7 @@ match_type_spec (gfc_typespec * ts, int implicit_flag) } if (sym->attr.flavor != FL_DERIVED - && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE) + && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; ts->type = BT_DERIVED; @@ -1801,7 +1803,7 @@ match_attr_spec (void) break; case DECL_DIMENSION: - t = gfc_add_dimension (¤t_attr, &seen_at[d]); + t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); break; case DECL_EXTERNAL: @@ -1829,7 +1831,7 @@ match_attr_spec (void) break; case DECL_PARAMETER: - t = gfc_add_flavor (¤t_attr, FL_PARAMETER, &seen_at[d]); + t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]); break; case DECL_POINTER: @@ -1837,15 +1839,17 @@ match_attr_spec (void) break; case DECL_PRIVATE: - t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, &seen_at[d]); + t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL, + &seen_at[d]); break; case DECL_PUBLIC: - t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, &seen_at[d]); + t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL, + &seen_at[d]); break; case DECL_SAVE: - t = gfc_add_save (¤t_attr, &seen_at[d]); + t = gfc_add_save (¤t_attr, NULL, &seen_at[d]); break; case DECL_TARGET: @@ -2080,7 +2084,7 @@ gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag) dummy procedure. We don't apply these attributes to formal arguments of statement functions. */ if (sym != NULL && !st_flag - && (gfc_add_dummy (&sym->attr, NULL) == FAILURE + && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE || gfc_missing_attr (&sym->attr, NULL) == FAILURE)) { m = MATCH_ERROR; @@ -2180,8 +2184,8 @@ match_result (gfc_symbol * function, gfc_symbol ** result) if (gfc_get_symbol (name, NULL, &r)) return MATCH_ERROR; - if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE - || gfc_add_result (&r->attr, NULL) == FAILURE) + if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE + || gfc_add_result (&r->attr, r->name, NULL) == FAILURE) return MATCH_ERROR; *result = r; @@ -2251,7 +2255,7 @@ gfc_match_function_decl (void) /* Make changes to the symbol. */ m = MATCH_ERROR; - if (gfc_add_function (&sym->attr, NULL) == FAILURE) + if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; if (gfc_missing_attr (&sym->attr, NULL) == FAILURE @@ -2326,13 +2330,13 @@ gfc_match_entry (void) if (state == COMP_SUBROUTINE) { - /* And entry in a subroutine. */ + /* An entry in a subroutine. */ m = gfc_match_formal_arglist (entry, 0, 1); if (m != MATCH_YES) return MATCH_ERROR; - if (gfc_add_entry (&entry->attr, NULL) == FAILURE - || gfc_add_subroutine (&entry->attr, NULL) == FAILURE) + if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE + || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE) return MATCH_ERROR; } else @@ -2346,8 +2350,8 @@ gfc_match_entry (void) if (gfc_match_eos () == MATCH_YES) { - if (gfc_add_entry (&entry->attr, NULL) == FAILURE - || gfc_add_function (&entry->attr, NULL) == FAILURE) + if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE + || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE) return MATCH_ERROR; entry->result = proc->result; @@ -2361,9 +2365,10 @@ gfc_match_entry (void) if (m != MATCH_YES) return MATCH_ERROR; - if (gfc_add_result (&result->attr, NULL) == FAILURE - || gfc_add_entry (&entry->attr, NULL) == FAILURE - || gfc_add_function (&entry->attr, NULL) == FAILURE) + if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE + || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE + || gfc_add_function (&entry->attr, result->name, + NULL) == FAILURE) return MATCH_ERROR; } @@ -2426,7 +2431,7 @@ gfc_match_subroutine (void) return MATCH_ERROR; gfc_new_block = sym; - if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE) + if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES) @@ -2713,7 +2718,7 @@ attr_decl1 (void) if ((current_attr.external || current_attr.intrinsic) && sym->attr.flavor != FL_PROCEDURE - && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE) + && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE) { m = MATCH_ERROR; goto cleanup; @@ -2840,7 +2845,7 @@ gfc_match_dimension (void) { gfc_clear_attr (¤t_attr); - gfc_add_dimension (¤t_attr, NULL); + gfc_add_dimension (¤t_attr, NULL, NULL); return attr_decl (); } @@ -2893,7 +2898,7 @@ access_attr_decl (gfc_statement st) if (gfc_add_access (&sym->attr, (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE, - NULL) == FAILURE) + sym->name, NULL) == FAILURE) return MATCH_ERROR; break; @@ -3036,7 +3041,7 @@ do_parm (void) } if (gfc_check_assign_symbol (sym, init) == FAILURE - || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE) + || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE) { m = MATCH_ERROR; goto cleanup; @@ -3120,7 +3125,8 @@ gfc_match_save (void) switch (m) { case MATCH_YES: - if (gfc_add_save (&sym->attr, &gfc_current_locus) == FAILURE) + if (gfc_add_save (&sym->attr, sym->name, + &gfc_current_locus) == FAILURE) return MATCH_ERROR; goto next_item; @@ -3189,7 +3195,8 @@ gfc_match_modproc (void) return MATCH_ERROR; if (sym->attr.proc != PROC_MODULE - && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE) + && gfc_add_procedure (&sym->attr, PROC_MODULE, + sym->name, NULL) == FAILURE) return MATCH_ERROR; if (gfc_add_interface (sym) == FAILURE) @@ -3236,7 +3243,7 @@ loop: return MATCH_ERROR; } - if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE) + if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE) return MATCH_ERROR; goto loop; } @@ -3249,7 +3256,7 @@ loop: return MATCH_ERROR; } - if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE) + if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE) return MATCH_ERROR; goto loop; } @@ -3294,7 +3301,7 @@ loop: derived type that is a pointer. The first part of the AND clause is true if a the symbol is not the return value of a function. */ if (sym->attr.flavor != FL_DERIVED - && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE) + && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; if (sym->components != NULL) @@ -3306,7 +3313,7 @@ loop: } if (attr.access != ACCESS_UNKNOWN - && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE) + && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE) return MATCH_ERROR; gfc_new_block = sym; diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index fb0c5764d45..cb5cb50fd92 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -277,11 +277,11 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars, switch (expr2->expr_type) { case EXPR_OP: - n = gfc_check_dependency (expr1, expr2->op1, vars, nvars); + n = gfc_check_dependency (expr1, expr2->value.op.op1, vars, nvars); if (n) return n; - if (expr2->op2) - return gfc_check_dependency (expr1, expr2->op2, vars, nvars); + if (expr2->value.op.op2) + return gfc_check_dependency (expr1, expr2->value.op.op2, vars, nvars); return 0; case EXPR_VARIABLE: diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 7af7a625f65..f8df9dabb12 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -106,7 +106,7 @@ gfc_show_actual_arglist (gfc_actual_arglist * a) for (; a; a = a->next) { gfc_status_char ('('); - if (a->name[0] != '\0') + if (a->name != NULL) gfc_status ("%s = ", a->name); if (a->expr != NULL) gfc_show_expr (a->expr); @@ -415,7 +415,7 @@ gfc_show_expr (gfc_expr * p) case EXPR_OP: gfc_status ("("); - switch (p->operator) + switch (p->value.op.operator) { case INTRINSIC_UPLUS: gfc_status ("U+ "); @@ -480,12 +480,12 @@ gfc_show_expr (gfc_expr * p) ("gfc_show_expr(): Bad intrinsic in expression!"); } - gfc_show_expr (p->op1); + gfc_show_expr (p->value.op.op1); - if (p->op2) + if (p->value.op.op2) { gfc_status (" "); - gfc_show_expr (p->op2); + gfc_show_expr (p->value.op.op2); } gfc_status (")"); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 87ce3e5fcbc..5867f9bfaa5 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -36,12 +36,9 @@ gfc_get_expr (void) e = gfc_getmem (sizeof (gfc_expr)); gfc_clear_ts (&e->ts); - e->op1 = NULL; - e->op2 = NULL; e->shape = NULL; e->ref = NULL; e->symtree = NULL; - e->uop = NULL; return e; } @@ -170,10 +167,10 @@ free_expr0 (gfc_expr * e) break; case EXPR_OP: - if (e->op1 != NULL) - gfc_free_expr (e->op1); - if (e->op2 != NULL) - gfc_free_expr (e->op2); + if (e->value.op.op1 != NULL) + gfc_free_expr (e->value.op.op1); + if (e->value.op.op2 != NULL) + gfc_free_expr (e->value.op.op2); break; case EXPR_FUNCTION: @@ -393,9 +390,6 @@ gfc_copy_expr (gfc_expr * p) q->value.character.string = s; memcpy (s, p->value.character.string, p->value.character.length + 1); - - q->op1 = gfc_copy_expr (p->op1); - q->op2 = gfc_copy_expr (p->op2); break; case EXPR_CONSTANT: @@ -440,17 +434,17 @@ gfc_copy_expr (gfc_expr * p) break; case EXPR_OP: - switch (q->operator) + switch (q->value.op.operator) { case INTRINSIC_NOT: case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: - q->op1 = gfc_copy_expr (p->op1); + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); break; default: /* Binary operators */ - q->op1 = gfc_copy_expr (p->op1); - q->op2 = gfc_copy_expr (p->op2); + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); + q->value.op.op2 = gfc_copy_expr (p->value.op.op2); break; } @@ -587,8 +581,8 @@ gfc_type_convert_binary (gfc_expr * e) { gfc_expr *op1, *op2; - op1 = e->op1; - op2 = e->op2; + op1 = e->value.op.op1; + op2 = e->value.op.op2; if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) { @@ -621,18 +615,18 @@ gfc_type_convert_binary (gfc_expr * e) { e->ts = op1->ts; - /* Special cose for ** operator. */ - if (e->operator == INTRINSIC_POWER) + /* Special case for ** operator. */ + if (e->value.op.operator == INTRINSIC_POWER) goto done; - gfc_convert_type (e->op2, &e->ts, 2); + gfc_convert_type (e->value.op.op2, &e->ts, 2); goto done; } if (op1->ts.type == BT_INTEGER) { e->ts = op2->ts; - gfc_convert_type (e->op1, &e->ts, 2); + gfc_convert_type (e->value.op.op1, &e->ts, 2); goto done; } @@ -643,9 +637,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->op1, &e->ts, 2); + gfc_convert_type (e->value.op.op1, &e->ts, 2); if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) - gfc_convert_type (e->op2, &e->ts, 2); + gfc_convert_type (e->value.op.op2, &e->ts, 2); done: return; @@ -668,9 +662,9 @@ gfc_is_constant_expr (gfc_expr * e) switch (e->expr_type) { case EXPR_OP: - rv = (gfc_is_constant_expr (e->op1) - && (e->op2 == NULL - || gfc_is_constant_expr (e->op2))); + rv = (gfc_is_constant_expr (e->value.op.op1) + && (e->value.op.op2 == NULL + || gfc_is_constant_expr (e->value.op.op2))); break; @@ -699,7 +693,8 @@ gfc_is_constant_expr (gfc_expr * e) break; case EXPR_SUBSTRING: - rv = gfc_is_constant_expr (e->op1) && gfc_is_constant_expr (e->op2); + rv = (gfc_is_constant_expr (e->ref->u.ss.start) + && gfc_is_constant_expr (e->ref->u.ss.end)); break; case EXPR_STRUCTURE: @@ -731,11 +726,11 @@ simplify_intrinsic_op (gfc_expr * p, int type) { gfc_expr *op1, *op2, *result; - if (p->operator == INTRINSIC_USER) + if (p->value.op.operator == INTRINSIC_USER) return SUCCESS; - op1 = p->op1; - op2 = p->op2; + op1 = p->value.op.op1; + op2 = p->value.op.op2; if (gfc_simplify_expr (op1, type) == FAILURE) return FAILURE; @@ -747,10 +742,10 @@ simplify_intrinsic_op (gfc_expr * p, int type) return SUCCESS; /* Rip p apart */ - p->op1 = NULL; - p->op2 = NULL; + p->value.op.op1 = NULL; + p->value.op.op2 = NULL; - switch (p->operator) + switch (p->value.op.operator) { case INTRINSIC_UPLUS: result = gfc_uplus (op1); @@ -1115,12 +1110,10 @@ gfc_simplify_expr (gfc_expr * p, int type) break; case EXPR_SUBSTRING: - if (gfc_simplify_expr (p->op1, type) == FAILURE - || gfc_simplify_expr (p->op2, type) == FAILURE) + if (simplify_ref_chain (p->ref, type) == FAILURE) return FAILURE; /* TODO: evaluate constant substrings. */ - break; case EXPR_OP: @@ -1195,15 +1188,17 @@ static try check_init_expr (gfc_expr *); static try check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) { + gfc_expr *op1 = e->value.op.op1; + gfc_expr *op2 = e->value.op.op2; - if ((*check_function) (e->op1) == FAILURE) + if ((*check_function) (op1) == FAILURE) return FAILURE; - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: - if (!numeric_type (et0 (e->op1))) + if (!numeric_type (et0 (op1))) goto not_numeric; break; @@ -1213,11 +1208,11 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) case INTRINSIC_GE: case INTRINSIC_LT: case INTRINSIC_LE: - if ((*check_function) (e->op2) == FAILURE) + if ((*check_function) (op2) == FAILURE) return FAILURE; - if (!(et0 (e->op1) == BT_CHARACTER && et0 (e->op2) == BT_CHARACTER) - && !(numeric_type (et0 (e->op1)) && numeric_type (et0 (e->op2)))) + if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) + && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) { gfc_error ("Numeric or CHARACTER operands are required in " "expression at %L", &e->where); @@ -1230,34 +1225,34 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) case INTRINSIC_TIMES: case INTRINSIC_DIVIDE: case INTRINSIC_POWER: - if ((*check_function) (e->op2) == FAILURE) + if ((*check_function) (op2) == FAILURE) return FAILURE; - if (!numeric_type (et0 (e->op1)) || !numeric_type (et0 (e->op2))) + if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) goto not_numeric; - if (e->operator == INTRINSIC_POWER - && check_function == check_init_expr && et0 (e->op2) != BT_INTEGER) + if (e->value.op.operator == INTRINSIC_POWER + && check_function == check_init_expr && et0 (op2) != BT_INTEGER) { gfc_error ("Exponent at %L must be INTEGER for an initialization " - "expression", &e->op2->where); + "expression", &op2->where); return FAILURE; } break; case INTRINSIC_CONCAT: - if ((*check_function) (e->op2) == FAILURE) + if ((*check_function) (op2) == FAILURE) return FAILURE; - if (et0 (e->op1) != BT_CHARACTER || et0 (e->op2) != BT_CHARACTER) + if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) { gfc_error ("Concatenation operator in expression at %L " - "must have two CHARACTER operands", &e->op1->where); + "must have two CHARACTER operands", &op1->where); return FAILURE; } - if (e->op1->ts.kind != e->op2->ts.kind) + if (op1->ts.kind != op2->ts.kind) { gfc_error ("Concat operator at %L must concatenate strings of the " "same kind", &e->where); @@ -1267,10 +1262,10 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) break; case INTRINSIC_NOT: - if (et0 (e->op1) != BT_LOGICAL) + if (et0 (op1) != BT_LOGICAL) { gfc_error (".NOT. operator in expression at %L must have a LOGICAL " - "operand", &e->op1->where); + "operand", &op1->where); return FAILURE; } @@ -1280,10 +1275,10 @@ check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) case INTRINSIC_OR: case INTRINSIC_EQV: case INTRINSIC_NEQV: - if ((*check_function) (e->op2) == FAILURE) + if ((*check_function) (op2) == FAILURE) return FAILURE; - if (et0 (e->op1) != BT_LOGICAL || et0 (e->op2) != BT_LOGICAL) + if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) { gfc_error ("LOGICAL operands are required in expression at %L", &e->where); @@ -1439,11 +1434,11 @@ check_init_expr (gfc_expr * e) break; case EXPR_SUBSTRING: - t = check_init_expr (e->op1); + t = check_init_expr (e->ref->u.ss.start); if (t == FAILURE) break; - t = check_init_expr (e->op2); + t = check_init_expr (e->ref->u.ss.end); if (t == SUCCESS) t = gfc_simplify_expr (e, 0); @@ -1662,11 +1657,11 @@ check_restricted (gfc_expr * e) break; case EXPR_SUBSTRING: - t = gfc_specification_expr (e->op1); + t = gfc_specification_expr (e->ref->u.ss.start); if (t == FAILURE) break; - t = gfc_specification_expr (e->op2); + t = gfc_specification_expr (e->ref->u.ss.end); if (t == SUCCESS) t = gfc_simplify_expr (e, 0); diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index b406bf041a0..7f04b7ca261 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -794,8 +794,7 @@ gfc_init_builtin_functions (void) BUILT_IN_CABS, "cabs", true); gfc_define_builtin ("__builtin_cabsf", func_cfloat_float, BUILT_IN_CABSF, "cabsf", true); - - + gfc_define_builtin ("__builtin_copysign", mfunc_double[1], BUILT_IN_COPYSIGN, "copysign", true); gfc_define_builtin ("__builtin_copysignf", mfunc_float[1], @@ -809,61 +808,28 @@ gfc_init_builtin_functions (void) /* Other builtin functions we use. */ - tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node); - tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp); - ftype = build_function_type (long_integer_type_node, tmp); - gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, - "__builtin_expect", true); - - tmp = tree_cons (NULL_TREE, size_type_node, void_list_node); - tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); - tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); - ftype = build_function_type (pvoid_type_node, tmp); - gfc_define_builtin ("__builtin_memcpy", ftype, BUILT_IN_MEMCPY, - "memcpy", false); - tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node); ftype = build_function_type (integer_type_node, tmp); - gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, "clz", true); + gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, + "__builtin_clz", true); tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node); ftype = build_function_type (integer_type_node, tmp); - gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, "clzl", true); + gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, + "__builtin_clzl", true); tmp = tree_cons (NULL_TREE, long_long_integer_type_node, void_list_node); ftype = build_function_type (integer_type_node, tmp); - gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, "clzll", true); - - tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node); - tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); - tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); - ftype = build_function_type (void_type_node, tmp); - gfc_define_builtin ("__builtin_init_trampoline", ftype, - BUILT_IN_INIT_TRAMPOLINE, "init_trampoline", false); - - tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node); - ftype = build_function_type (pvoid_type_node, tmp); - gfc_define_builtin ("__builtin_adjust_trampoline", ftype, - BUILT_IN_ADJUST_TRAMPOLINE, "adjust_trampoline", true); - - /* The stack_save, stack_restore, and alloca builtins aren't used directly. - They are inserted during gimplification to implement variable sized - stack allocation. */ - - ftype = build_function_type (pvoid_type_node, void_list_node); - gfc_define_builtin ("__builtin_stack_save", ftype, BUILT_IN_STACK_SAVE, - "stack_save", false); - - tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node); - ftype = build_function_type (void_type_node, tmp); - gfc_define_builtin ("__builtin_stack_restore", ftype, BUILT_IN_STACK_RESTORE, - "stack_restore", false); - - tmp = tree_cons (NULL_TREE, size_type_node, void_list_node); - ftype = build_function_type (pvoid_type_node, tmp); - gfc_define_builtin ("__builtin_alloca", ftype, BUILT_IN_ALLOCA, - "alloca", false); + gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, + "__builtin_clzll", true); + + tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node); + tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp); + ftype = build_function_type (long_integer_type_node, tmp); + gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, + "__builtin_expect", true); + build_common_builtin_nodes (); targetm.init_builtins (); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index c68f5af5ad5..adbccc11486 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -408,7 +408,8 @@ typedef struct unsigned in_namelist:1, in_common:1; unsigned function:1, subroutine:1, generic:1; - unsigned implicit_type:1; /* Type defined via implicit rules */ + unsigned implicit_type:1; /* Type defined via implicit rules. */ + unsigned untyped:1; /* No implicit type could be found. */ /* Function/subroutine attributes */ unsigned sequence:1, elemental:1, pure:1, recursive:1; @@ -539,7 +540,7 @@ gfc_array_spec; /* Components of derived types. */ typedef struct gfc_component { - char name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name; gfc_typespec ts; int pointer, dimension; @@ -570,7 +571,7 @@ gfc_formal_arglist; /* The gfc_actual_arglist structure is for actual arguments. */ typedef struct gfc_actual_arglist { - char name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name; /* Alternate return label when the expr member is null. */ struct gfc_st_label *label; @@ -635,7 +636,7 @@ gfc_interface; /* User operator nodes. These are like stripped down symbols. */ typedef struct { - char name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name; gfc_interface *operator; struct gfc_namespace *ns; @@ -651,8 +652,8 @@ gfc_user_op; typedef struct gfc_symbol { - char name[GFC_MAX_SYMBOL_LEN + 1]; /* Primary name, before renaming */ - char module[GFC_MAX_SYMBOL_LEN + 1]; /* Module this symbol came from */ + const char *name; /* Primary name, before renaming */ + const char *module; /* Module this symbol came from */ locus declared_at; gfc_typespec ts; @@ -743,7 +744,7 @@ gfc_entry_list; typedef struct gfc_symtree { BBT_HEADER (gfc_symtree); - char name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name; int ambiguous; union { @@ -1002,7 +1003,7 @@ gfc_resolve_f; typedef struct gfc_intrinsic_sym { - char name[GFC_MAX_SYMBOL_LEN + 1], lib_name[GFC_MAX_SYMBOL_LEN + 1]; + const char *name, *lib_name; gfc_intrinsic_arg *formal; gfc_typespec ts; int elemental, pure, generic, specific, actual_ok, standard; @@ -1043,15 +1044,11 @@ typedef struct gfc_expr int rank; mpz_t *shape; /* Can be NULL if shape is unknown at compile time */ - gfc_intrinsic_op operator; - /* Nonnull for functions and structure constructors */ gfc_symtree *symtree; - gfc_user_op *uop; gfc_ref *ref; - struct gfc_expr *op1, *op2; locus where; union @@ -1069,6 +1066,14 @@ typedef struct gfc_expr struct { + gfc_intrinsic_op operator; + gfc_user_op *uop; + struct gfc_expr *op1, *op2; + } + op; + + struct + { gfc_actual_arglist *actual; const char *name; /* Points to the ultimate name of the function */ gfc_intrinsic_sym *isym; @@ -1573,32 +1578,33 @@ void gfc_get_component_attr (symbol_attribute *, gfc_component *); void gfc_set_sym_referenced (gfc_symbol * sym); try gfc_add_allocatable (symbol_attribute *, locus *); -try gfc_add_dimension (symbol_attribute *, locus *); +try gfc_add_dimension (symbol_attribute *, const char *, locus *); try gfc_add_external (symbol_attribute *, locus *); try gfc_add_intrinsic (symbol_attribute *, locus *); try gfc_add_optional (symbol_attribute *, locus *); try gfc_add_pointer (symbol_attribute *, locus *); -try gfc_add_result (symbol_attribute *, locus *); -try gfc_add_save (symbol_attribute *, locus *); +try gfc_add_result (symbol_attribute *, const char *, locus *); +try gfc_add_save (symbol_attribute *, const char *, locus *); try gfc_add_saved_common (symbol_attribute *, locus *); try gfc_add_target (symbol_attribute *, locus *); -try gfc_add_dummy (symbol_attribute *, locus *); -try gfc_add_generic (symbol_attribute *, locus *); +try gfc_add_dummy (symbol_attribute *, const char *, locus *); +try gfc_add_generic (symbol_attribute *, const char *, locus *); try gfc_add_common (symbol_attribute *, locus *); -try gfc_add_in_common (symbol_attribute *, locus *); -try gfc_add_data (symbol_attribute *, locus *); -try gfc_add_in_namelist (symbol_attribute *, locus *); -try gfc_add_sequence (symbol_attribute *, locus *); +try gfc_add_in_common (symbol_attribute *, const char *, locus *); +try gfc_add_data (symbol_attribute *, const char *, locus *); +try gfc_add_in_namelist (symbol_attribute *, const char *, locus *); +try gfc_add_sequence (symbol_attribute *, const char *, locus *); try gfc_add_elemental (symbol_attribute *, locus *); try gfc_add_pure (symbol_attribute *, locus *); try gfc_add_recursive (symbol_attribute *, locus *); -try gfc_add_function (symbol_attribute *, locus *); -try gfc_add_subroutine (symbol_attribute *, locus *); - -try gfc_add_access (symbol_attribute *, gfc_access, locus *); -try gfc_add_flavor (symbol_attribute *, sym_flavor, locus *); -try gfc_add_entry (symbol_attribute *, locus *); -try gfc_add_procedure (symbol_attribute *, procedure_type, locus *); +try gfc_add_function (symbol_attribute *, const char *, locus *); +try gfc_add_subroutine (symbol_attribute *, const char *, locus *); + +try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *); +try gfc_add_flavor (symbol_attribute *, sym_flavor, const char *, locus *); +try gfc_add_entry (symbol_attribute *, const char *, locus *); +try gfc_add_procedure (symbol_attribute *, procedure_type, + const char *, locus *); try gfc_add_intent (symbol_attribute *, sym_intent, locus *); try gfc_add_explicit_interface (gfc_symbol *, ifsrc, gfc_formal_arglist *, locus *); @@ -1618,7 +1624,7 @@ void gfc_free_st_label (gfc_st_label *); void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *); try gfc_reference_st_label (gfc_st_label *, gfc_sl_type); -gfc_namespace *gfc_get_namespace (gfc_namespace *); +gfc_namespace *gfc_get_namespace (gfc_namespace *, int); gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *); gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *); gfc_user_op *gfc_get_uop (const char *); @@ -1648,8 +1654,8 @@ void gfc_save_all (gfc_namespace *); void gfc_symbol_state (void); -gfc_gsymbol *gfc_get_gsymbol (char *); -gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, char *); +gfc_gsymbol *gfc_get_gsymbol (const char *); +gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); /* intrinsic.c */ extern int gfc_init_expr; @@ -1658,7 +1664,7 @@ extern int gfc_init_expr; by placing it into a special module that is otherwise impossible to read or write. */ -#define gfc_intrinsic_symbol(SYM) strcpy (SYM->module, "(intrinsic)") +#define gfc_intrinsic_symbol(SYM) SYM->module = gfc_get_string ("(intrinsic)") void gfc_intrinsic_init_1 (void); void gfc_intrinsic_done_1 (void); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 3ff37684ed2..c3242f7b5a3 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1,8 +1,7 @@ \input texinfo @c -*-texinfo-*- @c %**start of header @setfilename gfortran.info -@set last-update 13 May 2004 -@set copyrights-gfortran 1999-2004 +@set copyrights-gfortran 1999-2005 @include gcc-common.texi @@ -83,10 +82,6 @@ Contributed by Steven Bosscher (@email{s.bosscher@@gcc.gnu.org}). @title Using GNU Fortran 95 @sp 2 @center Steven Bosscher -@sp 3 -@center Last updated @value{last-update} -@sp 1 -@center for version @value {version-GCC} @page @vskip 0pt plus 1filll For the @value{version-GCC} Version* diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index c127568275a..ecbf9a27aac 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -213,7 +213,8 @@ gfc_match_interface (void) if (gfc_get_symbol (name, NULL, &sym)) return MATCH_ERROR; - if (!sym->attr.generic && gfc_add_generic (&sym->attr, NULL) == FAILURE) + if (!sym->attr.generic + && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; current_interface.sym = gfc_new_block = sym; @@ -339,8 +340,9 @@ gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2) true names and module names are the same and the module name is nonnull, then they are equal. */ if (strcmp (ts1->derived->name, ts2->derived->name) == 0 - && ts1->derived->module[0] != '\0' - && strcmp (ts1->derived->module, ts2->derived->module) == 0) + && ((ts1->derived->module == NULL && ts2->derived->module == NULL) + || (ts1->derived != NULL && ts2->derived != NULL + && strcmp (ts1->derived->module, ts2->derived->module) == 0))) return 1; /* Compare type via the rules of the standard. Both types must have @@ -1164,7 +1166,7 @@ compare_actual_formal (gfc_actual_arglist ** ap, for (a = actual; a; a = a->next, f = f->next) { - if (a->name[0] != '\0') + if (a->name != NULL) { i = 0; for (f = formal; f; f = f->next, i++) @@ -1639,21 +1641,21 @@ gfc_extend_expr (gfc_expr * e) sym = NULL; actual = gfc_get_actual_arglist (); - actual->expr = e->op1; + actual->expr = e->value.op.op1; - if (e->op2 != NULL) + if (e->value.op.op2 != NULL) { actual->next = gfc_get_actual_arglist (); - actual->next->expr = e->op2; + actual->next->expr = e->value.op.op2; } - i = fold_unary (e->operator); + i = fold_unary (e->value.op.operator); if (i == INTRINSIC_USER) { for (ns = gfc_current_ns; ns; ns = ns->parent) { - uop = gfc_find_uop (e->uop->name, ns); + uop = gfc_find_uop (e->value.op.uop->name, ns); if (uop == NULL) continue; @@ -1686,6 +1688,8 @@ gfc_extend_expr (gfc_expr * e) e->expr_type = EXPR_FUNCTION; e->symtree = find_sym_in_symtree (sym); e->value.function.actual = actual; + e->value.function.esym = NULL; + e->value.function.isym = NULL; if (gfc_pure (NULL) && !gfc_pure (sym)) { diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 03d443f3c52..ebf5cb2edda 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -37,7 +37,8 @@ int gfc_init_expr = 0; /* Pointers to an intrinsic function and its argument names that are being checked. */ -char *gfc_current_intrinsic, *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +const char *gfc_current_intrinsic; +const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; locus *gfc_current_intrinsic_where; static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; @@ -107,7 +108,7 @@ gfc_get_intrinsic_sub_symbol (const char * name) /* Return a pointer to the name of a conversion function given two typespecs. */ -static char * +static const char * conv_name (gfc_typespec * from, gfc_typespec * to) { static char name[30]; @@ -115,7 +116,7 @@ conv_name (gfc_typespec * from, gfc_typespec * to) sprintf (name, "__convert_%c%d_%c%d", gfc_type_letter (from->type), from->kind, gfc_type_letter (to->type), to->kind); - return name; + return gfc_get_string (name); } @@ -127,7 +128,7 @@ static gfc_intrinsic_sym * find_conv (gfc_typespec * from, gfc_typespec * to) { gfc_intrinsic_sym *sym; - char *target; + const char *target; int i; target = conv_name (from, to); @@ -213,7 +214,7 @@ add_sym (const char *name, int elemental, int actual_ok ATTRIBUTE_UNUSED, bt type, int kind, int standard, gfc_check_f check, gfc_simplify_f simplify, gfc_resolve_f resolve, ...) { - + char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0' */ int optional, first_flag; va_list argp; @@ -233,10 +234,11 @@ add_sym (const char *name, int elemental, int actual_ok ATTRIBUTE_UNUSED, break; case SZ_NOTHING: - strcpy (next_sym->name, name); + next_sym->name = gfc_get_string (name); - strcpy (next_sym->lib_name, "_gfortran_"); - strcat (next_sym->lib_name, name); + strcpy (buf, "_gfortran_"); + strcat (buf, name); + next_sym->lib_name = gfc_get_string (buf); next_sym->elemental = elemental; next_sym->ts.type = type; @@ -785,11 +787,11 @@ make_generic (const char *name, gfc_generic_isym_id generic_id, int standard) g->generic = 1; g->specific = 1; g->generic_id = generic_id; - if ((g + 1)->name[0] != '\0') + if ((g + 1)->name != NULL) g->specific_head = g + 1; g++; - while (g->name[0] != '\0') + while (g->name != NULL) { g->next = g + 1; g->specific = 1; @@ -828,7 +830,7 @@ make_alias (const char *name, int standard) case SZ_NOTHING: next_sym[0] = next_sym[-1]; - strcpy (next_sym->name, name); + next_sym->name = gfc_get_string (name); next_sym++; break; @@ -894,7 +896,7 @@ add_functions (void) make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77); add_sym_1 ("achar", 1, 1, BT_CHARACTER, dc, GFC_STD_F95, - NULL, gfc_simplify_achar, NULL, + gfc_check_achar, gfc_simplify_achar, NULL, i, BT_INTEGER, di, REQUIRED); make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95); @@ -1781,7 +1783,7 @@ add_functions (void) make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU); add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di, GFC_STD_F95, - NULL, gfc_simplify_selected_int_kind, NULL, + gfc_check_selected_int_kind, gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED); make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95); @@ -2152,8 +2154,8 @@ add_conv (bt from_type, int from_kind, bt to_type, int to_kind, sym = conversion + nconv; - strcpy (sym->name, conv_name (&from, &to)); - strcpy (sym->lib_name, sym->name); + sym->name = conv_name (&from, &to); + sym->lib_name = sym->name; sym->simplify.cc = simplify; sym->elemental = 1; sym->ts = to; @@ -2241,7 +2243,7 @@ gfc_intrinsic_init_1 (void) nargs = nfunc = nsub = nconv = 0; /* Create a namespace to hold the resolved intrinsic symbols. */ - gfc_intrinsic_namespace = gfc_get_namespace (NULL); + gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0); sizing = SZ_FUNCS; add_functions (); @@ -2359,7 +2361,7 @@ sort_actual (const char *name, gfc_actual_arglist ** ap, if (a == NULL) goto optional; - if (a->name[0] != '\0') + if (a->name != NULL) goto keywords; f->actual = a; diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 41593efe9c1..3f5fcba3736 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -1,6 +1,7 @@ /* Header file for intrinsics check, resolve and simplify function prototypes. - Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 + Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb This file is part of GCC. @@ -31,6 +32,7 @@ try gfc_check_a_xkind (gfc_expr *, gfc_expr *); try gfc_check_a_p (gfc_expr *, gfc_expr *); try gfc_check_abs (gfc_expr *); +try gfc_check_achar (gfc_expr *); try gfc_check_all_any (gfc_expr *, gfc_expr *); try gfc_check_allocated (gfc_expr *); try gfc_check_associated (gfc_expr *, gfc_expr *); @@ -93,6 +95,7 @@ try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_scale (gfc_expr *, gfc_expr *); try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_second_sub (gfc_expr *); +try gfc_check_selected_int_kind (gfc_expr *); try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *); try gfc_check_set_exponent (gfc_expr *, gfc_expr *); try gfc_check_shape (gfc_expr *); @@ -365,6 +368,6 @@ void gfc_resolve_unlink_sub (gfc_code *); #define MAX_INTRINSIC_ARGS 5 -extern char *gfc_current_intrinsic, - *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +extern const char *gfc_current_intrinsic; +extern const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; extern locus *gfc_current_intrinsic_where; diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index a4ab2251761..9a30b7df2e1 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -383,9 +383,9 @@ gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b) { temp.expr_type = EXPR_OP; gfc_clear_ts (&temp.ts); - temp.operator = INTRINSIC_NONE; - temp.op1 = a; - temp.op2 = b; + temp.value.op.operator = INTRINSIC_NONE; + temp.value.op.op1 = a; + temp.value.op.op2 = b; gfc_type_convert_binary (&temp); f->ts = temp.ts; } @@ -753,9 +753,9 @@ gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b) { temp.expr_type = EXPR_OP; gfc_clear_ts (&temp.ts); - temp.operator = INTRINSIC_NONE; - temp.op1 = a; - temp.op2 = b; + temp.value.op.operator = INTRINSIC_NONE; + temp.value.op.op1 = a; + temp.value.op.op2 = b; gfc_type_convert_binary (&temp); f->ts = temp.ts; } diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index abd8ef89acb..2a364478530 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -266,7 +266,8 @@ gfc_match_label (void) } if (gfc_new_block->attr.flavor != FL_LABEL - && gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, NULL) == FAILURE) + && gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, + gfc_new_block->name, NULL) == FAILURE) return MATCH_ERROR; for (p = gfc_state_stack; p; p = p->previous) @@ -806,7 +807,7 @@ gfc_match_program (void) if (m == MATCH_ERROR) return m; - if (gfc_add_flavor (&sym->attr, FL_PROGRAM, NULL) == FAILURE) + if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE) return MATCH_ERROR; gfc_new_block = sym; @@ -2013,7 +2014,7 @@ gfc_match_call (void) if (!sym->attr.generic && !sym->attr.subroutine - && gfc_add_subroutine (&sym->attr, NULL) == FAILURE) + && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; if (gfc_match_eos () != MATCH_YES) @@ -2237,7 +2238,7 @@ gfc_match_common (void) goto cleanup; } - if (gfc_add_in_common (&sym->attr, NULL) == FAILURE) + if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; if (sym->value != NULL @@ -2252,7 +2253,7 @@ gfc_match_common (void) goto cleanup; } - if (gfc_add_in_common (&sym->attr, NULL) == FAILURE) + if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; /* Derived type names must have the SEQUENCE attribute. */ @@ -2287,7 +2288,7 @@ gfc_match_common (void) goto cleanup; } - if (gfc_add_dimension (&sym->attr, NULL) == FAILURE) + if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; if (sym->attr.pointer) @@ -2353,7 +2354,7 @@ gfc_match_block_data (void) if (gfc_get_symbol (name, NULL, &sym)) return MATCH_ERROR; - if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE) + if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE) return MATCH_ERROR; gfc_new_block = sym; @@ -2403,7 +2404,8 @@ gfc_match_namelist (void) } if (group_name->attr.flavor != FL_NAMELIST - && gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE) + && gfc_add_flavor (&group_name->attr, FL_NAMELIST, + group_name->name, NULL) == FAILURE) return MATCH_ERROR; for (;;) @@ -2415,7 +2417,7 @@ gfc_match_namelist (void) goto error; if (sym->attr.in_namelist == 0 - && gfc_add_in_namelist (&sym->attr, NULL) == FAILURE) + && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE) goto error; nl = gfc_get_namelist (); @@ -2471,7 +2473,8 @@ gfc_match_module (void) if (m != MATCH_YES) return m; - if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE) + if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, + gfc_new_block->name, NULL) == FAILURE) return MATCH_ERROR; return MATCH_YES; @@ -2587,7 +2590,8 @@ gfc_match_st_function (void) gfc_push_error (&old_error); - if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE) + if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, + sym->name, NULL) == FAILURE) goto undo_error; if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c index bde8d603dea..04fd31f3609 100644 --- a/gcc/fortran/matchexp.c +++ b/gcc/fortran/matchexp.c @@ -179,11 +179,11 @@ build_node (gfc_intrinsic_op operator, locus * where, new = gfc_get_expr (); new->expr_type = EXPR_OP; - new->operator = operator; + new->value.op.operator = operator; new->where = *where; - new->op1 = op1; - new->op2 = op2; + new->value.op.op1 = op1; + new->value.op.op2 = op2; return new; } @@ -214,7 +214,7 @@ match_level_1 (gfc_expr ** result) else { f = build_node (INTRINSIC_USER, &where, e, NULL); - f->uop = uop; + f->value.op.uop = uop; *result = f; } @@ -873,7 +873,7 @@ gfc_match_expr (gfc_expr ** result) } all = build_node (INTRINSIC_USER, &where, all, e); - all->uop = uop; + all->value.op.uop = uop; } *result = all; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 3670a3a49ad..4b69b738db1 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -655,7 +655,8 @@ compare_true_names (void * _t1, void * _t2) t1 = (true_name *) _t1; t2 = (true_name *) _t2; - c = strcmp (t1->sym->module, t2->sym->module); + c = ((t1->sym->module > t2->sym->module) + - (t1->sym->module < t2->sym->module)); if (c != 0) return c; @@ -673,8 +674,11 @@ find_true_name (const char *name, const char *module) gfc_symbol sym; int c; - strcpy (sym.name, name); - strcpy (sym.module, module); + sym.name = gfc_get_string (name); + if (module != NULL) + sym.module = gfc_get_string (module); + else + sym.module = NULL; t.sym = &sym; p = true_name_root; @@ -1341,8 +1345,33 @@ mio_allocated_string (const char *s) } -/* Read or write a string that is in static memory or inside of some - already-allocated structure. */ +/* Read or write a string that is in static memory. */ + +static void +mio_pool_string (const char **stringp) +{ + /* TODO: one could write the string only once, and refer to it via a + fixup pointer. */ + + /* As a special case we have to deal with a NULL string. This + happens for the 'module' member of 'gfc_symbol's that are not in a + module. We read / write these as the empty string. */ + if (iomode == IO_OUTPUT) + { + const char *p = *stringp == NULL ? "" : *stringp; + write_atom (ATOM_STRING, p); + } + else + { + require_atom (ATOM_STRING); + *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string); + gfc_free (atom_string); + } +} + + +/* Read or write a string that is inside of some already-allocated + structure. */ static void mio_internal_string (char *string) @@ -1802,7 +1831,7 @@ mio_component_ref (gfc_component ** cp, gfc_symbol * sym) p->type = P_COMPONENT; if (iomode == IO_OUTPUT) - mio_internal_string ((*cp)->name); + mio_pool_string (&(*cp)->name); else { mio_internal_string (name); @@ -1851,7 +1880,7 @@ mio_component (gfc_component * c) if (p->type == P_UNKNOWN) p->type = P_COMPONENT; - mio_internal_string (c->name); + mio_pool_string (&c->name); mio_typespec (&c->ts); mio_array_spec (&c->as); @@ -1907,7 +1936,7 @@ mio_actual_arg (gfc_actual_arglist * a) { mio_lparen (); - mio_internal_string (a->name); + mio_pool_string (&a->name); mio_expr (&a->expr); mio_rparen (); } @@ -2404,14 +2433,15 @@ mio_expr (gfc_expr ** ep) switch (e->expr_type) { case EXPR_OP: - e->operator = MIO_NAME(gfc_intrinsic_op) (e->operator, intrinsics); + e->value.op.operator + = MIO_NAME(gfc_intrinsic_op) (e->value.op.operator, intrinsics); - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: case INTRINSIC_NOT: - mio_expr (&e->op1); + mio_expr (&e->value.op.op1); break; case INTRINSIC_PLUS: @@ -2430,8 +2460,8 @@ mio_expr (gfc_expr ** ep) case INTRINSIC_GE: case INTRINSIC_LT: case INTRINSIC_LE: - mio_expr (&e->op1); - mio_expr (&e->op2); + mio_expr (&e->value.op.op1); + mio_expr (&e->value.op.op2); break; default: @@ -2483,8 +2513,7 @@ mio_expr (gfc_expr ** ep) case EXPR_SUBSTRING: e->value.character.string = (char *) mio_allocated_string (e->value.character.string); - mio_expr (&e->op1); - mio_expr (&e->op2); + mio_ref_list (&e->ref); break; case EXPR_STRUCTURE: @@ -2599,14 +2628,14 @@ mio_interface (gfc_interface ** ip) /* Save/restore a named operator interface. */ static void -mio_symbol_interface (char *name, char *module, +mio_symbol_interface (const char **name, const char **module, gfc_interface ** ip) { mio_lparen (); - mio_internal_string (name); - mio_internal_string (module); + mio_pool_string (name); + mio_pool_string (module); mio_interface_rest (ip); } @@ -2628,7 +2657,7 @@ mio_namespace_ref (gfc_namespace ** nsp) ns = (gfc_namespace *)p->u.pointer; if (ns == NULL) { - ns = gfc_get_namespace (NULL); + ns = gfc_get_namespace (NULL, 0); associate_integer_pointer (p, ns); } else @@ -2879,12 +2908,12 @@ load_needed (pointer_info * p) the namespaces that hold the formal parameters of module procedures. */ - ns = gfc_get_namespace (NULL); + ns = gfc_get_namespace (NULL, 0); associate_integer_pointer (q, ns); } sym = gfc_new_symbol (p->u.rsym.true_name, ns); - strcpy (sym->module, p->u.rsym.module); + sym->module = gfc_get_string (p->u.rsym.module); associate_integer_pointer (p, sym); } @@ -3037,7 +3066,7 @@ read_module (void) sym = info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns); - strcpy (sym->module, info->u.rsym.module); + sym->module = gfc_get_string (info->u.rsym.module); } st->n.sym = sym; @@ -3170,7 +3199,7 @@ write_common (gfc_symtree *st) write_common(st->right); mio_lparen(); - mio_internal_string(st->name); + mio_pool_string(&st->name); p = st->n.common; mio_symbol_ref(&p->head); @@ -3190,9 +3219,9 @@ write_symbol (int n, gfc_symbol * sym) gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name); mio_integer (&n); - mio_internal_string (sym->name); + mio_pool_string (&sym->name); - mio_internal_string (sym->module); + mio_pool_string (&sym->module); mio_pointer_ref (&sym->ns); mio_symbol (sym); @@ -3217,8 +3246,8 @@ write_symbol0 (gfc_symtree * st) write_symbol0 (st->right); sym = st->n.sym; - if (sym->module[0] == '\0') - strcpy (sym->module, module_name); + if (sym->module == NULL) + sym->module = gfc_get_string (module_name); if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic && !sym->attr.subroutine && !sym->attr.function) @@ -3265,8 +3294,8 @@ write_symbol1 (pointer_info * p) /* FIXME: This shouldn't be necessary, but it works around deficiencies in the module loader or/and symbol handling. */ - if (p->u.wsym.sym->module[0] == '\0' && p->u.wsym.sym->attr.dummy) - strcpy (p->u.wsym.sym->module, module_name); + if (p->u.wsym.sym->module == NULL && p->u.wsym.sym->attr.dummy) + p->u.wsym.sym->module = gfc_get_string (module_name); p->u.wsym.state = WRITTEN; write_symbol (p->integer, p->u.wsym.sym); @@ -3281,12 +3310,13 @@ static void write_operator (gfc_user_op * uop) { static char nullstring[] = ""; + const char *p = nullstring; if (uop->operator == NULL || !gfc_check_access (uop->access, uop->ns->default_access)) return; - mio_symbol_interface (uop->name, nullstring, &uop->operator); + mio_symbol_interface (&uop->name, &p, &uop->operator); } @@ -3300,7 +3330,7 @@ write_generic (gfc_symbol * sym) || !gfc_check_access (sym->attr.access, sym->ns->default_access)) return; - mio_symbol_interface (sym->name, sym->module, &sym->generic); + mio_symbol_interface (&sym->name, &sym->module, &sym->generic); } @@ -3323,7 +3353,7 @@ write_symtree (gfc_symtree * st) if (p == NULL) gfc_internal_error ("write_symtree(): Symbol not written"); - mio_internal_string (st->name); + mio_pool_string (&st->name); mio_integer (&st->ambiguous); mio_integer (&p->integer); } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 484c05ce2d6..a3f0ac19539 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1349,7 +1349,8 @@ parse_derived (void) } seen_sequence = 1; - gfc_add_sequence (&gfc_current_block ()->attr, NULL); + gfc_add_sequence (&gfc_current_block ()->attr, + gfc_current_block ()->name, NULL); break; default: @@ -1404,7 +1405,7 @@ parse_interface (void) current_state = COMP_NONE; loop: - gfc_current_ns = gfc_get_namespace (current_interface.ns); + gfc_current_ns = gfc_get_namespace (current_interface.ns, 0); st = next_statement (); switch (st) @@ -1451,9 +1452,9 @@ loop: if (current_state == COMP_NONE) { if (new_state == COMP_FUNCTION) - gfc_add_function (&sym->attr, NULL); - if (new_state == COMP_SUBROUTINE) - gfc_add_subroutine (&sym->attr, NULL); + gfc_add_function (&sym->attr, sym->name, NULL); + else if (new_state == COMP_SUBROUTINE) + gfc_add_subroutine (&sym->attr, sym->name, NULL); current_state = new_state; } @@ -2169,7 +2170,7 @@ parse_contained (int module) do { - gfc_current_ns = gfc_get_namespace (parent_ns); + gfc_current_ns = gfc_get_namespace (parent_ns, 1); gfc_current_ns->sibling = parent_ns->contained; parent_ns->contained = gfc_current_ns; @@ -2200,15 +2201,15 @@ parse_contained (int module) gfc_new_block->name); else { - if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, + if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name, &gfc_new_block->declared_at) == SUCCESS) { if (st == ST_FUNCTION) - gfc_add_function (&sym->attr, + gfc_add_function (&sym->attr, sym->name, &gfc_new_block->declared_at); else - gfc_add_subroutine (&sym->attr, + gfc_add_subroutine (&sym->attr, sym->name, &gfc_new_block->declared_at); } } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index a2d1d1f5004..f3c51ab4675 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1273,7 +1273,7 @@ match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base) if (name[0] != '\0') { for (a = base; a; a = a->next) - if (strcmp (a->name, name) == 0) + if (a->name != NULL && strcmp (a->name, name) == 0) { gfc_error ("Keyword '%s' at %C has already appeared in the current " @@ -1282,7 +1282,7 @@ match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base) } } - strcpy (actual->name, name); + actual->name = gfc_get_string (name); return MATCH_YES; cleanup: @@ -1877,7 +1877,7 @@ gfc_match_rvalue (gfc_expr ** result) e->rank = sym->as->rank; if (!sym->attr.function - && gfc_add_function (&sym->attr, NULL) == FAILURE) + && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE) { m = MATCH_ERROR; break; @@ -1905,7 +1905,8 @@ gfc_match_rvalue (gfc_expr ** result) if (sym->attr.dimension) { - if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE) + if (gfc_add_flavor (&sym->attr, FL_VARIABLE, + sym->name, NULL) == FAILURE) { m = MATCH_ERROR; break; @@ -1930,7 +1931,8 @@ gfc_match_rvalue (gfc_expr ** result) e->symtree = symtree; e->expr_type = EXPR_VARIABLE; - if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE) + if (gfc_add_flavor (&sym->attr, FL_VARIABLE, + sym->name, NULL) == FAILURE) { m = MATCH_ERROR; break; @@ -1964,7 +1966,8 @@ gfc_match_rvalue (gfc_expr ** result) e->expr_type = EXPR_VARIABLE; if (sym->attr.flavor != FL_VARIABLE - && gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE) + && gfc_add_flavor (&sym->attr, FL_VARIABLE, + sym->name, NULL) == FAILURE) { m = MATCH_ERROR; break; @@ -1990,7 +1993,7 @@ gfc_match_rvalue (gfc_expr ** result) e->expr_type = EXPR_FUNCTION; if (!sym->attr.function - && gfc_add_function (&sym->attr, NULL) == FAILURE) + && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE) { m = MATCH_ERROR; break; @@ -2072,7 +2075,8 @@ gfc_match_variable (gfc_expr ** result, int equiv_flag) break; case FL_UNKNOWN: - if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE) + if (gfc_add_flavor (&sym->attr, FL_VARIABLE, + sym->name, NULL) == FAILURE) return MATCH_ERROR; break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 442b205b7bc..4d98f462a82 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -151,7 +151,7 @@ resolve_formal_arglist (gfc_symbol * proc) A procedure specification would have already set the type. */ if (sym->attr.flavor == FL_UNKNOWN) - gfc_add_flavor (&sym->attr, FL_VARIABLE, &sym->declared_at); + gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at); if (gfc_pure (proc)) { @@ -364,12 +364,12 @@ resolve_entries (gfc_namespace * ns) gfc_get_ha_symbol (name, &proc); gcc_assert (proc != NULL); - gfc_add_procedure (&proc->attr, PROC_INTERNAL, NULL); + gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL); if (ns->proc_name->attr.subroutine) - gfc_add_subroutine (&proc->attr, NULL); + gfc_add_subroutine (&proc->attr, proc->name, NULL); else { - gfc_add_function (&proc->attr, NULL); + gfc_add_function (&proc->attr, proc->name, NULL); gfc_internal_error ("TODO: Functions with alternate entry points"); } proc->attr.access = ACCESS_PRIVATE; @@ -884,8 +884,8 @@ set_type: } -/* Figure out if if a function reference is pure or not. Also sets the name - of the function for a potential error message. Returns nonzero if the +/* Figure out if a function reference is pure or not. Also set the name + of the function for a potential error message. Return nonzero if the function is PURE, zero if not. */ static int @@ -1262,10 +1262,10 @@ resolve_operator (gfc_expr * e) /* Resolve all subnodes-- give them types. */ - switch (e->operator) + switch (e->value.op.operator) { default: - if (gfc_resolve_expr (e->op2) == FAILURE) + if (gfc_resolve_expr (e->value.op.op2) == FAILURE) return FAILURE; /* Fall through... */ @@ -1273,17 +1273,17 @@ resolve_operator (gfc_expr * e) case INTRINSIC_NOT: case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: - if (gfc_resolve_expr (e->op1) == FAILURE) + if (gfc_resolve_expr (e->value.op.op1) == FAILURE) return FAILURE; break; } /* Typecheck the new node. */ - op1 = e->op1; - op2 = e->op2; + op1 = e->value.op.op1; + op2 = e->value.op.op2; - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: @@ -1296,7 +1296,7 @@ resolve_operator (gfc_expr * e) } sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s", - gfc_op2string (e->operator), gfc_typename (&e->ts)); + gfc_op2string (e->value.op.operator), gfc_typename (&e->ts)); goto bad_op; case INTRINSIC_PLUS: @@ -1312,7 +1312,7 @@ resolve_operator (gfc_expr * e) sprintf (msg, "Operands of binary numeric operator '%s' at %%L are %s/%s", - gfc_op2string (e->operator), gfc_typename (&op1->ts), + gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts), gfc_typename (&op2->ts)); goto bad_op; @@ -1345,7 +1345,7 @@ resolve_operator (gfc_expr * e) } sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s", - gfc_op2string (e->operator), gfc_typename (&op1->ts), + gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts), gfc_typename (&op2->ts)); goto bad_op; @@ -1393,7 +1393,7 @@ resolve_operator (gfc_expr * e) } sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s", - gfc_op2string (e->operator), gfc_typename (&op1->ts), + gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts), gfc_typename (&op2->ts)); goto bad_op; @@ -1401,10 +1401,10 @@ resolve_operator (gfc_expr * e) case INTRINSIC_USER: if (op2 == NULL) sprintf (msg, "Operand of user operator '%s' at %%L is %s", - e->uop->name, gfc_typename (&op1->ts)); + e->value.op.uop->name, gfc_typename (&op1->ts)); else sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s", - e->uop->name, gfc_typename (&op1->ts), + e->value.op.uop->name, gfc_typename (&op1->ts), gfc_typename (&op2->ts)); goto bad_op; @@ -1417,7 +1417,7 @@ resolve_operator (gfc_expr * e) t = SUCCESS; - switch (e->operator) + switch (e->value.op.operator) { case INTRINSIC_PLUS: case INTRINSIC_MINUS: @@ -3327,23 +3327,27 @@ gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol) gfc_error ("Unsupported statement while finding forall index in " "expression"); break; - default: + + case EXPR_OP: + /* Find the FORALL index in the first operand. */ + if (expr->value.op.op1) + { + if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS) + return SUCCESS; + } + + /* Find the FORALL index in the second operand. */ + if (expr->value.op.op2) + { + if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS) + return SUCCESS; + } break; - } - /* Find the FORALL index in the first operand. */ - if (expr->op1) - { - if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS) - return SUCCESS; + default: + break; } - /* Find the FORALL index in the second operand. */ - if (expr->op2) - { - if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS) - return SUCCESS; - } return FAILURE; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 423f3336d8b..81bc0159909 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -592,7 +592,7 @@ gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k) gfc_expr *ceil, *result; int kind; - kind = get_kind (BT_REAL, k, "CEILING", gfc_default_real_kind); + kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind); if (kind == -1) return &gfc_bad_expr; @@ -1017,7 +1017,7 @@ gfc_simplify_floor (gfc_expr * e, gfc_expr * k) mpfr_t floor; int kind; - kind = get_kind (BT_REAL, k, "FLOOR", gfc_default_real_kind); + kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind); if (kind == -1) gfc_internal_error ("gfc_simplify_floor(): Bad kind"); @@ -1473,7 +1473,7 @@ gfc_simplify_int (gfc_expr * e, gfc_expr * k) gfc_expr *rpart, *rtrunc, *result; int kind; - kind = get_kind (BT_REAL, k, "INT", gfc_default_real_kind); + kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); if (kind == -1) return &gfc_bad_expr; diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index b6515376e38..f4b32006ad1 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -1,5 +1,5 @@ /* Build executable statement trees. - Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 7333dbbb442..0b5e8e727a4 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -179,8 +179,7 @@ gfc_merge_new_implicit (gfc_typespec * ts) } -/* Given a symbol, return a pointer to the typespec for it's default - type. */ +/* Given a symbol, return a pointer to the typespec for its default type. */ gfc_typespec * gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns) @@ -214,9 +213,12 @@ gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns) if (ts->type == BT_UNKNOWN) { - if (error_flag) - gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name, - &sym->declared_at); + if (error_flag && !sym->attr.untyped) + { + gfc_error ("Symbol '%s' at %L has no IMPLICIT type", + sym->name, &sym->declared_at); + sym->attr.untyped = 1; /* Ensure we only give an error once. */ + } return FAILURE; } @@ -237,7 +239,7 @@ gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns) #define conf2(a) if (attr->a) { a2 = a; goto conflict; } static try -check_conflict (symbol_attribute * attr, locus * where) +check_conflict (symbol_attribute * attr, const char * name, locus * where) { static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", @@ -426,7 +428,13 @@ check_conflict (symbol_attribute * attr, locus * where) return SUCCESS; conflict: - gfc_error ("%s attribute conflicts with %s attribute at %L", a1, a2, where); + if (name == NULL) + gfc_error ("%s attribute conflicts with %s attribute at %L", + a1, a2, where); + else + gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L", + a1, a2, name, where); + return FAILURE; } @@ -456,7 +464,7 @@ gfc_set_sym_referenced (gfc_symbol * sym) nonzero if not. */ static int -check_used (symbol_attribute * attr, locus * where) +check_used (symbol_attribute * attr, const char * name, locus * where) { if (attr->use_assoc == 0) @@ -465,17 +473,21 @@ check_used (symbol_attribute * attr, locus * where) if (where == NULL) where = &gfc_current_locus; - gfc_error ("Cannot change attributes of USE-associated symbol at %L", - where); + if (name == NULL) + gfc_error ("Cannot change attributes of USE-associated symbol at %L", + where); + else + gfc_error ("Cannot change attributes of USE-associated symbol %s at %L", + name, where); return 1; } /* Used to prevent changing the attributes of a symbol after it has been - used. This check is only done from dummy variable as only these can be + used. This check is only done for dummy variables as only these can be used in specification expressions. Applying this to all symbols causes - error when we reach the body of a contained function. */ + an error when we reach the body of a contained function. */ static int check_done (symbol_attribute * attr, locus * where) @@ -511,7 +523,7 @@ try gfc_add_allocatable (symbol_attribute * attr, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, NULL, where) || check_done (attr, where)) return FAILURE; if (attr->allocatable) @@ -521,15 +533,15 @@ gfc_add_allocatable (symbol_attribute * attr, locus * where) } attr->allocatable = 1; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } try -gfc_add_dimension (symbol_attribute * attr, locus * where) +gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, name, where) || check_done (attr, where)) return FAILURE; if (attr->dimension) @@ -539,7 +551,7 @@ gfc_add_dimension (symbol_attribute * attr, locus * where) } attr->dimension = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } @@ -547,7 +559,7 @@ try gfc_add_external (symbol_attribute * attr, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, NULL, where) || check_done (attr, where)) return FAILURE; if (attr->external) @@ -558,7 +570,7 @@ gfc_add_external (symbol_attribute * attr, locus * where) attr->external = 1; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } @@ -566,7 +578,7 @@ try gfc_add_intrinsic (symbol_attribute * attr, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, NULL, where) || check_done (attr, where)) return FAILURE; if (attr->intrinsic) @@ -577,7 +589,7 @@ gfc_add_intrinsic (symbol_attribute * attr, locus * where) attr->intrinsic = 1; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } @@ -585,7 +597,7 @@ try gfc_add_optional (symbol_attribute * attr, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, NULL, where) || check_done (attr, where)) return FAILURE; if (attr->optional) @@ -595,7 +607,7 @@ gfc_add_optional (symbol_attribute * attr, locus * where) } attr->optional = 1; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } @@ -603,31 +615,31 @@ try gfc_add_pointer (symbol_attribute * attr, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, NULL, where) || check_done (attr, where)) return FAILURE; attr->pointer = 1; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } try -gfc_add_result (symbol_attribute * attr, locus * where) +gfc_add_result (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, name, where) || check_done (attr, where)) return FAILURE; attr->result = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } try -gfc_add_save (symbol_attribute * attr, locus * where) +gfc_add_save (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, where)) + if (check_used (attr, name, where)) return FAILURE; if (gfc_pure (NULL)) @@ -645,7 +657,7 @@ gfc_add_save (symbol_attribute * attr, locus * where) } attr->save = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } @@ -653,7 +665,7 @@ try gfc_add_target (symbol_attribute * attr, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, NULL, where) || check_done (attr, where)) return FAILURE; if (attr->target) @@ -663,72 +675,73 @@ gfc_add_target (symbol_attribute * attr, locus * where) } attr->target = 1; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } try -gfc_add_dummy (symbol_attribute * attr, locus * where) +gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, where)) + if (check_used (attr, name, where)) return FAILURE; - /* Duplicate dummy arguments are allow due to ENTRY statements. */ + /* Duplicate dummy arguments are allowed due to ENTRY statements. */ attr->dummy = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } try -gfc_add_in_common (symbol_attribute * attr, locus * where) +gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, name, where) || check_done (attr, where)) return FAILURE; /* Duplicate attribute already checked for. */ attr->in_common = 1; - if (check_conflict (attr, where) == FAILURE) + if (check_conflict (attr, name, where) == FAILURE) return FAILURE; if (attr->flavor == FL_VARIABLE) return SUCCESS; - return gfc_add_flavor (attr, FL_VARIABLE, where); + return gfc_add_flavor (attr, FL_VARIABLE, name, where); } try -gfc_add_data (symbol_attribute *attr, locus *where) +gfc_add_data (symbol_attribute *attr, const char *name, locus *where) { - if (check_used (attr, where)) + if (check_used (attr, name, where)) return FAILURE; attr->data = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } try -gfc_add_in_namelist (symbol_attribute * attr, locus * where) +gfc_add_in_namelist (symbol_attribute * attr, const char *name, + locus * where) { attr->in_namelist = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } try -gfc_add_sequence (symbol_attribute * attr, locus * where) +gfc_add_sequence (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, where)) + if (check_used (attr, name, where)) return FAILURE; attr->sequence = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } @@ -736,11 +749,11 @@ try gfc_add_elemental (symbol_attribute * attr, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, NULL, where) || check_done (attr, where)) return FAILURE; attr->elemental = 1; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } @@ -748,11 +761,11 @@ try gfc_add_pure (symbol_attribute * attr, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, NULL, where) || check_done (attr, where)) return FAILURE; attr->pure = 1; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } @@ -760,19 +773,19 @@ try gfc_add_recursive (symbol_attribute * attr, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, NULL, where) || check_done (attr, where)) return FAILURE; attr->recursive = 1; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } try -gfc_add_entry (symbol_attribute * attr, locus * where) +gfc_add_entry (symbol_attribute * attr, const char *name, locus * where) { - if (check_used (attr, where)) + if (check_used (attr, name, where)) return FAILURE; if (attr->entry) @@ -782,59 +795,60 @@ gfc_add_entry (symbol_attribute * attr, locus * where) } attr->entry = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } try -gfc_add_function (symbol_attribute * attr, locus * where) +gfc_add_function (symbol_attribute * attr, const char *name, locus * where) { if (attr->flavor != FL_PROCEDURE - && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE) + && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) return FAILURE; attr->function = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } try -gfc_add_subroutine (symbol_attribute * attr, locus * where) +gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where) { if (attr->flavor != FL_PROCEDURE - && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE) + && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) return FAILURE; attr->subroutine = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } try -gfc_add_generic (symbol_attribute * attr, locus * where) +gfc_add_generic (symbol_attribute * attr, const char *name, locus * where) { if (attr->flavor != FL_PROCEDURE - && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE) + && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) return FAILURE; attr->generic = 1; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } -/* Flavors are special because some flavors are not what fortran +/* Flavors are special because some flavors are not what Fortran considers attributes and can be reaffirmed multiple times. */ try -gfc_add_flavor (symbol_attribute * attr, sym_flavor f, locus * where) +gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name, + locus * where) { if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED - || f == FL_NAMELIST) && check_used (attr, where)) + || f == FL_NAMELIST) && check_used (attr, name, where)) return FAILURE; if (attr->flavor == f && f == FL_VARIABLE) @@ -854,19 +868,20 @@ gfc_add_flavor (symbol_attribute * attr, sym_flavor f, locus * where) attr->flavor = f; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } try -gfc_add_procedure (symbol_attribute * attr, procedure_type t, locus * where) +gfc_add_procedure (symbol_attribute * attr, procedure_type t, + const char *name, locus * where) { - if (check_used (attr, where) || check_done (attr, where)) + if (check_used (attr, name, where) || check_done (attr, where)) return FAILURE; if (attr->flavor != FL_PROCEDURE - && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE) + && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) return FAILURE; if (where == NULL) @@ -886,11 +901,11 @@ gfc_add_procedure (symbol_attribute * attr, procedure_type t, locus * where) /* Statement functions are always scalar and functions. */ if (t == PROC_ST_FUNCTION - && ((!attr->function && gfc_add_function (attr, where) == FAILURE) + && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE) || attr->dimension)) return FAILURE; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } @@ -898,13 +913,13 @@ try gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where) { - if (check_used (attr, where)) + if (check_used (attr, NULL, where)) return FAILURE; if (attr->intent == INTENT_UNKNOWN) { attr->intent = intent; - return check_conflict (attr, where); + return check_conflict (attr, NULL, where); } if (where == NULL) @@ -921,13 +936,14 @@ gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where) /* No checks for use-association in public and private statements. */ try -gfc_add_access (symbol_attribute * attr, gfc_access access, locus * where) +gfc_add_access (symbol_attribute * attr, gfc_access access, + const char *name, locus * where) { if (attr->access == ACCESS_UNKNOWN) { attr->access = access; - return check_conflict (attr, where); + return check_conflict (attr, name, where); } if (where == NULL) @@ -943,7 +959,7 @@ gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source, gfc_formal_arglist * formal, locus * where) { - if (check_used (&sym->attr, where)) + if (check_used (&sym->attr, sym->name, where)) return FAILURE; if (where == NULL) @@ -1033,37 +1049,37 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE) goto fail; - if (src->dimension && gfc_add_dimension (dest, where) == FAILURE) + if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE) goto fail; if (src->optional && gfc_add_optional (dest, where) == FAILURE) goto fail; if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) goto fail; - if (src->save && gfc_add_save (dest, where) == FAILURE) + if (src->save && gfc_add_save (dest, NULL, where) == FAILURE) goto fail; if (src->target && gfc_add_target (dest, where) == FAILURE) goto fail; - if (src->dummy && gfc_add_dummy (dest, where) == FAILURE) + if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE) goto fail; - if (src->result && gfc_add_result (dest, where) == FAILURE) + if (src->result && gfc_add_result (dest, NULL, where) == FAILURE) goto fail; if (src->entry) dest->entry = 1; - if (src->in_namelist && gfc_add_in_namelist (dest, where) == FAILURE) + if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE) goto fail; - if (src->in_common && gfc_add_in_common (dest, where) == FAILURE) + if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE) goto fail; - if (src->generic && gfc_add_generic (dest, where) == FAILURE) + if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE) goto fail; - if (src->function && gfc_add_function (dest, where) == FAILURE) + if (src->function && gfc_add_function (dest, NULL, where) == FAILURE) goto fail; - if (src->subroutine && gfc_add_subroutine (dest, where) == FAILURE) + if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE) goto fail; - if (src->sequence && gfc_add_sequence (dest, where) == FAILURE) + if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE) goto fail; if (src->elemental && gfc_add_elemental (dest, where) == FAILURE) goto fail; @@ -1073,7 +1089,7 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) goto fail; if (src->flavor != FL_UNKNOWN - && gfc_add_flavor (dest, src->flavor, where) == FAILURE) + && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE) goto fail; if (src->intent != INTENT_UNKNOWN @@ -1081,14 +1097,14 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) goto fail; if (src->access != ACCESS_UNKNOWN - && gfc_add_access (dest, src->access, where) == FAILURE) + && gfc_add_access (dest, src->access, NULL, where) == FAILURE) goto fail; if (gfc_missing_attr (dest, where) == FAILURE) goto fail; /* The subroutines that set these bits also cause flavors to be set, - and that has already happened in the original, so don't let to + and that has already happened in the original, so don't let it happen again. */ if (src->external) dest->external = 1; @@ -1133,7 +1149,7 @@ gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** componen tail = p; } - /* Allocate new component */ + /* Allocate a new component. */ p = gfc_get_component (); if (tail == NULL) @@ -1141,7 +1157,7 @@ gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** componen else tail->next = p; - strcpy (p->name, name); + p->name = gfc_get_string (name); p->loc = gfc_current_locus; *component = p; @@ -1180,21 +1196,24 @@ switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to) have to have a derived type in a parent unit. We find the node in the other namespace and point the symtree node in this namespace to that node. Further reference to this name point to the correct - node. If we can't find the node in a parent namespace, then have + node. If we can't find the node in a parent namespace, then we have an error. This subroutine takes a pointer to a symbol node and returns a pointer to the translated node or NULL for an error. Usually there is no translation and we return the node we were passed. */ -static gfc_symtree * -gfc_use_ha_derived (gfc_symbol * sym) +gfc_symbol * +gfc_use_derived (gfc_symbol * sym) { gfc_symbol *s, *p; gfc_typespec *t; gfc_symtree *st; int i; + if (sym->components != NULL) + return sym; /* Already defined. */ + if (sym->ns->parent == NULL) goto bad; @@ -1237,7 +1256,7 @@ gfc_use_ha_derived (gfc_symbol * sym) namelists, common lists and interface lists. */ gfc_free_symbol (sym); - return st; + return s; bad: gfc_error ("Derived type '%s' at %C is being used before it is defined", @@ -1246,22 +1265,6 @@ bad: } -gfc_symbol * -gfc_use_derived (gfc_symbol * sym) -{ - gfc_symtree *st; - - if (sym->components != NULL) - return sym; /* Already defined */ - - st = gfc_use_ha_derived (sym); - if (st) - return st->n.sym; - else - return NULL; -} - - /* Given a derived type node and a component name, try to locate the component structure. Returns the NULL pointer if the component is not found or the components are private. */ @@ -1520,7 +1523,7 @@ done: the internal subprograms must be read before we can start generating code for the host. - Given the tricky nature of the fortran grammar, we must be able to + Given the tricky nature of the Fortran grammar, we must be able to undo changes made to a symbol table if the current interpretation of a statement is found to be incorrect. Whenever a symbol is looked up, we make a copy of it and link to it. All of these @@ -1531,10 +1534,11 @@ done: this case, that symbol has been used as a host associated variable at some previous time. */ -/* Allocate a new namespace structure. */ +/* Allocate a new namespace structure. Copies the implicit types from + PARENT if PARENT_TYPES is set. */ gfc_namespace * -gfc_get_namespace (gfc_namespace * parent) +gfc_get_namespace (gfc_namespace * parent, int parent_types) { gfc_namespace *ns; gfc_typespec *ts; @@ -1556,7 +1560,7 @@ gfc_get_namespace (gfc_namespace * parent) ns->set_flag[i - 'a'] = 0; ts = &ns->default_type[i - 'a']; - if (ns->parent != NULL) + if (parent_types && ns->parent != NULL) { /* Copy parent settings */ *ts = ns->parent->default_type[i - 'a']; @@ -1609,7 +1613,7 @@ gfc_new_symtree (gfc_symtree ** root, const char *name) gfc_symtree *st; st = gfc_getmem (sizeof (gfc_symtree)); - strcpy (st->name, name); + st->name = gfc_get_string (name); gfc_insert_bbt (root, st, compare_symtree); return st; @@ -1625,7 +1629,7 @@ delete_symtree (gfc_symtree ** root, const char *name) st0 = gfc_find_symtree (*root, name); - strcpy (st.name, name); + st.name = gfc_get_string (name); gfc_delete_bbt (root, &st, compare_symtree); gfc_free (st0); @@ -1670,7 +1674,7 @@ gfc_get_uop (const char *name) st = gfc_new_symtree (&gfc_current_ns->uop_root, name); uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op)); - strcpy (uop->name, name); + uop->name = gfc_get_string (name); uop->access = ACCESS_UNKNOWN; uop->ns = gfc_current_ns; @@ -1739,7 +1743,7 @@ gfc_new_symbol (const char *name, gfc_namespace * ns) if (strlen (name) > GFC_MAX_SYMBOL_LEN) gfc_internal_error ("new_symbol(): Symbol name too long"); - strcpy (p->name, name); + p->name = gfc_get_string (name); return p; } @@ -1750,7 +1754,7 @@ static void ambiguous_symbol (const char *name, gfc_symtree * st) { - if (st->n.sym->module[0]) + if (st->n.sym->module) gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " "from module '%s'", name, st->n.sym->name, st->n.sym->module); else @@ -2243,7 +2247,7 @@ void gfc_symbol_init_2 (void) { - gfc_current_ns = gfc_get_namespace (NULL); + gfc_current_ns = gfc_get_namespace (NULL, 0); } @@ -2326,7 +2330,7 @@ save_symbol (gfc_symbol * sym) || sym->attr.flavor != FL_VARIABLE) return; - gfc_add_save (&sym->attr, &sym->declared_at); + gfc_add_save (&sym->attr, sym->name, &sym->declared_at); } @@ -2358,7 +2362,7 @@ gfc_symbol_state(void) { /* Search a tree for the global symbol. */ gfc_gsymbol * -gfc_find_gsymbol (gfc_gsymbol *symbol, char *name) +gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name) { gfc_gsymbol *s; @@ -2395,7 +2399,7 @@ gsym_compare (void * _s1, void * _s2) /* Get a global symbol, creating it if it doesn't exist. */ gfc_gsymbol * -gfc_get_gsymbol (char *name) +gfc_get_gsymbol (const char *name) { gfc_gsymbol *s; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index e281619741d..a97bcc593a3 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1271,7 +1271,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) /* Also the data pointer. */ tmp = gfc_conv_array_data (se.expr); /* If this is a variable or address of a variable we use it directly. - Otherwise we must evaluate it now to to avoid break dependency + Otherwise we must evaluate it now to avoid breaking dependency analysis by pulling the expressions for elemental array indices inside the loop. */ if (!(DECL_P (tmp) @@ -3071,7 +3071,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) gcc_assert (!sym->attr.use_assoc); gcc_assert (!TREE_STATIC (decl)); - gcc_assert (!sym->module[0]); + gcc_assert (!sym->module); if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.cl->backend_decl)) @@ -4194,18 +4194,18 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) gfc_ss *head2; gfc_ss *newss; - head = gfc_walk_subexpr (ss, expr->op1); - if (expr->op2 == NULL) + head = gfc_walk_subexpr (ss, expr->value.op.op1); + if (expr->value.op.op2 == NULL) head2 = head; else - head2 = gfc_walk_subexpr (head, expr->op2); + head2 = gfc_walk_subexpr (head, expr->value.op.op2); /* All operands are scalar. Pass back and let the caller deal with it. */ if (head2 == ss) return head2; /* All operands require scalarization. */ - if (head != ss && (expr->op2 == NULL || head2 != head)) + if (head != ss && (expr->value.op.op2 == NULL || head2 != head)) return head2; /* One of the operands needs scalarization, the other is scalar. @@ -4223,7 +4223,7 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) gcc_assert (head); newss->next = ss; head->next = newss; - newss->expr = expr->op1; + newss->expr = expr->value.op.op1; } else /* head2 == head */ { @@ -4231,7 +4231,7 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) /* Second operand is scalar. */ newss->next = head2; head2 = newss; - newss->expr = expr->op2; + newss->expr = expr->value.op.op2; } return head2; diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 6a6e1395f10..35ea8012034 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -288,7 +288,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) /* Create a namespace to store symbols for common blocks. */ if (gfc_common_ns == NULL) - gfc_common_ns = gfc_get_namespace (NULL); + gfc_common_ns = gfc_get_namespace (NULL, 0); gfc_get_symbol (com->name, gfc_common_ns, &common_sym); decl = common_sym->backend_decl; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 6567695ad29..b81b9862207 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -272,7 +272,7 @@ gfc_sym_mangled_identifier (gfc_symbol * sym) { char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; - if (sym->module[0] == 0) + if (sym->module == NULL) return gfc_sym_identifier (sym); else { @@ -290,8 +290,8 @@ gfc_sym_mangled_function_id (gfc_symbol * sym) int has_underscore; char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; - if (sym->module[0] == 0 || sym->attr.proc == PROC_EXTERNAL - || (sym->module[0] != 0 && sym->attr.if_source == IFSRC_IFBODY)) + if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL + || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY)) { if (strcmp (sym->name, "MAIN__") == 0 || sym->attr.proc == PROC_INTRINSIC) @@ -404,7 +404,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) DECL_EXTERNAL (decl) = 1; TREE_PUBLIC (decl) = 1; } - else if (sym->module[0] && !sym->attr.result && !sym->attr.dummy) + else if (sym->module && !sym->attr.result && !sym->attr.dummy) { /* TODO: Don't set sym->module for result or dummy variables. */ gcc_assert (current_function_decl == NULL_TREE); @@ -766,7 +766,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Symbols from modules should have their assembler names mangled. This is done here rather than in gfc_finish_var_decl because it is different for string length variables. */ - if (sym->module[0]) + if (sym->module) SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym)); if (sym->attr.dimension) @@ -808,7 +808,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) { char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2]; - if (sym->module[0]) + if (sym->module) { /* Also prefix the mangled name for symbols from modules. */ strcpy (&name[1], sym->name); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 494faa44135..685a9f97f9e 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -414,7 +414,7 @@ gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr) gcc_assert (expr->ts.type != BT_CHARACTER); /* Initialize the operand. */ gfc_init_se (&operand, se); - gfc_conv_expr_val (&operand, expr->op1); + gfc_conv_expr_val (&operand, expr->value.op.op1); gfc_add_block_to_block (&se->pre, &operand.pre); type = gfc_typenode_for_spec (&expr->ts); @@ -607,25 +607,25 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) tree tmp; gfc_init_se (&lse, se); - gfc_conv_expr_val (&lse, expr->op1); + gfc_conv_expr_val (&lse, expr->value.op.op1); gfc_add_block_to_block (&se->pre, &lse.pre); gfc_init_se (&rse, se); - gfc_conv_expr_val (&rse, expr->op2); + gfc_conv_expr_val (&rse, expr->value.op.op2); gfc_add_block_to_block (&se->pre, &rse.pre); - if (expr->op2->ts.type == BT_INTEGER - && expr->op2->expr_type == EXPR_CONSTANT) + if (expr->value.op.op2->ts.type == BT_INTEGER + && expr->value.op.op2->expr_type == EXPR_CONSTANT) if (gfc_conv_cst_int_power (se, lse.expr, rse.expr)) return; gfc_int4_type_node = gfc_get_int_type (4); - kind = expr->op1->ts.kind; - switch (expr->op2->ts.type) + kind = expr->value.op.op1->ts.kind; + switch (expr->value.op.op2->ts.type) { case BT_INTEGER: - ikind = expr->op2->ts.kind; + ikind = expr->value.op.op2->ts.kind; switch (ikind) { case 1: @@ -648,7 +648,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) { case 1: case 2: - if (expr->op1->ts.type == BT_INTEGER) + if (expr->value.op.op1->ts.type == BT_INTEGER) lse.expr = convert (gfc_int4_type_node, lse.expr); else gcc_unreachable (); @@ -666,7 +666,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) gcc_unreachable (); } - switch (expr->op1->ts.type) + switch (expr->value.op.op1->ts.type) { case BT_INTEGER: fndecl = gfor_fndecl_math_powi[kind][ikind].integer; @@ -780,14 +780,14 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) tree args; tree tmp; - gcc_assert (expr->op1->ts.type == BT_CHARACTER - && expr->op2->ts.type == BT_CHARACTER); + gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER + && expr->value.op.op2->ts.type == BT_CHARACTER); gfc_init_se (&lse, se); - gfc_conv_expr (&lse, expr->op1); + gfc_conv_expr (&lse, expr->value.op.op1); gfc_conv_string_parameter (&lse); gfc_init_se (&rse, se); - gfc_conv_expr (&rse, expr->op2); + gfc_conv_expr (&rse, expr->value.op.op2); gfc_conv_string_parameter (&rse); gfc_add_block_to_block (&se->pre, &lse.pre); @@ -846,10 +846,10 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) checkstring = 0; lop = 0; - switch (expr->operator) + switch (expr->value.op.operator) { case INTRINSIC_UPLUS: - gfc_conv_expr (se, expr->op1); + gfc_conv_expr (se, expr->value.op.op1); return; case INTRINSIC_UMINUS: @@ -951,19 +951,19 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) } /* The only exception to this is **, which is handled separately anyway. */ - gcc_assert (expr->op1->ts.type == expr->op2->ts.type); + gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type); - if (checkstring && expr->op1->ts.type != BT_CHARACTER) + if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER) checkstring = 0; /* lhs */ gfc_init_se (&lse, se); - gfc_conv_expr (&lse, expr->op1); + gfc_conv_expr (&lse, expr->value.op.op1); gfc_add_block_to_block (&se->pre, &lse.pre); /* rhs */ gfc_init_se (&rse, se); - gfc_conv_expr (&rse, expr->op2); + gfc_conv_expr (&rse, expr->value.op.op2); gfc_add_block_to_block (&se->pre, &rse.pre); /* For string comparisons we generate a library call, and compare the return diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index b5ef13f5e16..26f05f1e9fb 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -816,7 +816,7 @@ gfc_trans_inquire (gfc_code * code) static gfc_expr * -gfc_new_nml_name_expr (char * name) +gfc_new_nml_name_expr (const char * name) { gfc_expr * nml_name; nml_name = gfc_get_expr(); @@ -825,7 +825,8 @@ gfc_new_nml_name_expr (char * name) nml_name->ts.kind = gfc_default_character_kind; nml_name->ts.type = BT_CHARACTER; nml_name->value.character.length = strlen(name); - nml_name->value.character.string = name; + nml_name->value.character.string = gfc_getmem (strlen (name) + 1); + strcpy (nml_name->value.character.string, name); return nml_name; } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 7a55cbc48c9..da074c8b454 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1578,10 +1578,8 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree size, /* Form the mask expression according to the mask tree list. */ if (wheremask) { - tmp2 = wheremask; - if (tmp2 != NULL) - wheremaskexpr = gfc_build_array_ref (tmp2, count3); - tmp2 = TREE_CHAIN (tmp2); + wheremaskexpr = gfc_build_array_ref (wheremask, count3); + tmp2 = TREE_CHAIN (wheremask); while (tmp2) { tmp1 = gfc_build_array_ref (tmp2, count3); @@ -1684,10 +1682,8 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree size, /* Form the mask expression according to the mask tree list. */ if (wheremask) { - tmp2 = wheremask; - if (tmp2 != NULL) - wheremaskexpr = gfc_build_array_ref (tmp2, count3); - tmp2 = TREE_CHAIN (tmp2); + wheremaskexpr = gfc_build_array_ref (wheremask, count3); + tmp2 = TREE_CHAIN (wheremask); while (tmp2) { tmp1 = gfc_build_array_ref (tmp2, count3); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index b670f7a3888..f16e23ccff5 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -118,7 +118,7 @@ typedef enum scalarization loop. */ GFC_SS_SCALAR, - /* Like GFC_SS_SCALAR except it evaluates a pointer the the expression. + /* Like GFC_SS_SCALAR except it evaluates a pointer to the expression. Used for elemental function parameters. */ GFC_SS_REFERENCE, |