diff -Nrcpad gcc-4.1.1/gcc/fortran/ChangeLog gcc-4.1.2/gcc/fortran/ChangeLog *** gcc-4.1.1/gcc/fortran/ChangeLog Wed May 24 23:42:08 2006 --- gcc-4.1.2/gcc/fortran/ChangeLog Wed Feb 14 05:11:41 2007 *************** *** 1,3 **** --- 1,1059 ---- + 2007-02-13 Release Manager + + * GCC 4.1.2 released. + + 2007-02-10 Bernhard Fischer + + Backport from trunk + PR fortran/24783 + * resolve.c (resolve_variable): Get the implicit type from the + symbols namespace rather than the default namespace. Fix whitespace. + (resolve_formal_arglist, resolve_equivalence): Fix typo. + + 2007-01-27 Steven Bosscher + Steven G. Kargl + + PR fortran/30278 + * fortran/io.c (next_char): Deal with backslash escaped characters. + Issue warnings in non -std=gnu cases. + * fortran/primary.c (next_string_char): Issue warnings in non + + 2007-01-24 Roger Sayle + + * trans-intrinsic.c (gfc_conv_intrinsic_sign): Call gfc_evaluate_now + to prevent re-evaluation of first operand. + + 2006-12-25 Jerry DeLisle + + PR fortran/30200 + * trans-io.c (build_dt): Move post block for format_expr to end. + + 2006-12-13 Steven G. Kargl + + Revert Paul Thomas' commit from 2006-12-09 + + 2006-12-09 Paul Thomas + + PR fortran/29821 + * resolve.c (resolve_operator): Only return result of + gfc_simplify_expr if expression is constant. + + PR fortran/29912 + * trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL if the + lhs and rhs character lengths are not constant and equal for + character array valued functions. + + PR fortran/29916 + * resolve.c (resolve_symbol): Allow host-associated variables + in the specification expression of an array-valued function. + * expr.c (check_restricted): Accept host-associated dummy + array indices. + + PR fortran/30003 + * trans-array.c (gfc_trans_create_temp_array): Set the section + ends to zero. + (gfc_conv_section_startstride): Declare an expression for end, + set it from a the array reference and evaluate it for the info + structure. Zero the ends in the ss structure and set end, used + in the bounds check, from the info structure. + trans.h: Add and end array to the gfc_ss_info structure. + + PR fortran/29820 + * trans-array.c (gfc_get_derived_type): Once done, spread the + backend_decl to all identical derived types in all sibling + namespaces. + + 2006-11-26 Andrew Pinski + + PR fortran/29982 + * trans-expr.c (gfc_conv_expr_reference): Strip off NOP_EXPRs. + + 2006-11-24 Francois-Xavier Coudert + + PR fortran/29391 + PR fortran/29489 + * simplify.c (simplify_bound): Fix the simplification of + LBOUND/UBOUND intrinsics. + * trans-intrinsic.c (simplify_bound): Fix the logic, and + remove an erroneous assert. + + 2006-11-24 Francois-Xavier Coudert + + PR fortran/29391 + * trans-intrinsic.c (gfc_conv_intrinsic_bound): Generate correct + code for LBOUND and UBOUND intrinsics. + + 2006-11-11 Francois-Xavier Coudert + + PR fortran/29713 + * expr.c (gfc_simplify_expr): Correct memory allocation. + + 2006-11-10 Paul Thomas + + Backport from mainline. + + PR fortran/29371 + * trans-expr.c (gfc_trans_pointer_assignment): Add the expression + for the assignment of null to the data field to se->pre, rather + than block. + + PR fortran/29392 + * data.c (create_character_intializer): Copy and simplify + the expressions for the start and end of a sub-string + reference. + + PR fortran/29216 + PR fortran/29314 + * gfortran.h : Add EXEC_INIT_ASSIGN. + * dump-parse-tree.c (gfc_show_code_node): The same. + * trans-expr.c (gfc_trans_init_assign): New function. + * trans-stmt.h : Add prototype for gfc_trans_init_assign. + * trans.c (gfc_trans_code): Implement EXEC_INIT_ASSIGN. + * resolve.c (resolve_allocate_exp): Replace EXEC_ASSIGN by + EXEC_INIT_ASSIGN. + (resolve_code): EXEC_INIT_ASSIGN does not need resolution. + (apply_default_init): New function. + (resolve_symbol): Call it for derived types that become + defined but which do not already have an initialization + expression.. + * st.c (gfc_free_statement): Include EXEC_INIT_ASSIGN. + + PR fortran/29387 + * trans-intrinsic.c (gfc_conv_intrinsic_len): Rearrange to have + a specific case for EXPR_VARIABLE and, in default, build an ss + to call gfc_conv_expr_descriptor for array expressions.. + + PR fortran/29490 + * trans-expr.c (gfc_set_interface_mapping_bounds): In the case + that GFC_TYPE_ARRAY_LBOUND is not available, use descriptor + values for it and GFC_TYPE_ARRAY_UBOUND. + + PR fortran/29641 + * trans-types.c (gfc_get_derived_type): If the derived type + namespace has neither a parent nor a proc_name, set NULL for + the search namespace. + + PR fortran/24518 + * trans-intrinsic.c (gfc_conv_intrinsic_mod): Use built_in fmod + for both MOD and MODULO, if it is available. + + PR fortran/29565 + * trans-expr.c (gfc_conv_aliased_arg): For an INTENT(OUT), save + the declarations from the unused loops by merging the block + scope for each; this ensures that the temporary is declared. + + 2006-11-08 Erik Edelmann + + PR fortran/29630 + PR fortran/29679 + * expr.c (find_array_section): Support vector subscripts. Don't + add sizes for dimen_type == DIMEN_ELEMENT to the shape array. + + 2006-11-06 Paul Thomas + + Backport from mainline. + + PR fortran/29373 + * decl.c (get_proc_name, gfc_match_function_decl): Add + attr.implicit_type to conditions that throw error for + existing explicit interface and that allow new type- + spec to be applied. + + PR fortran/29407 + * resolve.c (resolve_fl_namelist): Do not check for + namelist/procedure conflict, if the symbol corresponds + to a good local variable declaration. + + PR fortran/27701 + * decl.c (get_proc_name): Replace the detection of a declared + procedure by the presence of a formal argument list by the + attributes of the symbol and the presence of an explicit + interface. + + PR fortran/29232 + * resolve.c (resolve_fl_variable): See if the host association + of a derived type is blocked by the presence of another type I + object in the current namespace. + + PR fortran/29364 + * resolve.c (resolve_fl_derived): Check for the presence of + the derived type for a derived type component. + + PR fortran/24398 + * module.c (gfc_use_module): Check that the first words in a + module file are 'GFORTRAN module'. + + PR fortran/29115 + * resolve.c (resolve_structure_cons): It is an error if the + pointer component elements of a derived type constructor are + not pointer or target. + + PR fortran/29211 + * trans-stmt.c (generate_loop_for_temp_to_lhs, + generate_loop_for_rhs_to_temp): Provide a string length for + the temporary by copying that of the other side of the scalar + assignment. + + PR fortran/29098 + * resolve.c (resolve_structure_cons): Do not return FAILURE if + component expression is NULL. + + 2006-11-03 Francois-Xavier Coudert + + PR fortran/29067 + * decl.c (gfc_set_constant_character_len): NULL-terminate the + character constant string. + * data.c (create_character_intializer): Likewise. + * expr.c (gfc_simplify_expr): NULL-terminate the substring + character constant. + * primary.c (match_hollerith_constant): NULL-terminate the + character constant string. + + 2006-10-24 Erik Edelmann + + PR fortran/29393 + * expr.c (simplify_parameter_variable): Keep rank of original + expression. + + 2006-10-24 Paul Thomas + + PR fortran/29284 + PR fortran/29321 + PR fortran/29322 + * trans-expr.c (gfc_conv_function_call): Check the expression + and the formal symbol are present when testing the actual + argument. + + PR fortran/25091 + PR fortran/25092 + * resolve.c (resolve_entries): It is an error if the entries + of an array-valued function do not have the same shape. + + 2006-10-16 Steven G. Kargl + + PR fortran/29403 + * io.c (match_io): Check for a default-char-expr for PRINT format. + + 2006-10-06 Jakub Jelinek + + PR fortran/28415 + * trans-decl.c (gfc_finish_var_decl): With -fno-automatic, don't + make artificial variables or pointer to variable automatic array + TREE_STATIC. + + 2006-09-19 Paul Thomas + Steven Bosscher + + PR fortran/29101 + * trans-stmt.c (gfc_trans_character_select): Store the label + from select_string and then clean up any temporaries from the + conversion of the select expression, before branching to the + selected case. + + 2006-09-18 Paul Thomas + + PR fortran/28526 + * primary.c (match_variable): If the compiler is in a module + specification block, an interface block or a contains section, + reset host_flag to force the changed symbols mechanism. + + PR fortran/29101 + * trans-stmt.c (gfc_trans_character_select): Add the post block + for the expression to the main block, after the call to + select_string and the last label. + + 2006-09-18 Paul Thomas + + PR fortran/29060 + * iresolve.c (resolve_spread): Build shape for result if the + source shape is available and dim and ncopies are constants. + + 2006-09-18 Tobias Schlüter + + PR fortran/28817 + PR fortran/21918 + * trans-decl.c (generate_local_decl): Change from 'warning' to + 'gfc_warning' to have line numbers correctly reported. + + 2006-09-15 Paul Thomas + + PR fortran/29051 + * decl.c (match_old_style_init): Set the 'where' field of the + gfc_data structure 'newdata'. + + * match.c (match_case_eos): Add a comprehensible error message. + + 2006-09-12 Paul Thomas + + PR fortran/28890 + trans-expr.c (gfc_conv_function_call): Obtain the string length + of a dummy character(*) function from the symbol if it is not + already translated. For a call to a character(*) function, use + the passed, hidden string length argument, which is available + from the backend_decl of the formal argument. + resolve.c (resolve_function): It is an error if a function call + to a character(*) function is other than a dummy procedure or + an intrinsic. + + 2006-09-10 Paul Thomas + + PR fortran/28923 + expr.c (find_array_section): Only use the array lower and upper + bounds for the start and end of the sections, where the expr is + NULL. + + PR fortran/28959 + trans-types.c (gfc_get_derived_type): Use the parent namespace of + the procedure if the type's own namespace does not have a parent. + + 2006-09-05 Paul Thomas + + PR fortran/28908 + * gfortran.h : Restore the gfc_dt_list structure and reference + to it in gfc_namespace. + * resolve.c (resolve_fl_derived): Restore the building of the + list of derived types for the current namespace. Modify the + restored code so that a check is made to see if the symbol is + already in the list. + (resolve_fntype): Make sure that the specification block + version of the derived type is used for a module function that + returns that type. + * symbol.c (gfc_free_dt_list): Restore. + (gfc_free_namespace): Restore call to previous. + * trans-types.c (copy_dt_decls_ifequal): Restore. + (gfc_get_derived_type): Restore all the paraphenalia for + association of derived types, including calls to previous. + Modify the restored code such that all derived types are built + if their symbols are found in the parent namespace; not just + non-module types. Add backend_decls to like derived types in + sibling namespaces, as well as that of the derived type. + + 2006-08-30 Paul Thomas + + PR fortran/28885 + * trans-expr.c (gfc_conv_aliased_arg): Ensure that the temp + declaration is retained for INTENT(OUT) arguments. + + PR fortran/28873 + PR fortran/20067 + * resolve.c (resolve_generic_f): Make error message more + comprehensible. + (resolve_generic_s): Restructure search for specific procedures + to be similar to resolve_generic_f and change to similar error + message. Ensure that symbol reference is refreshed, in case + the search produces a NULL. + (resolve_specific_s): Restructure search, as above and as + resolve_specific_f. Ensure that symbol reference is refreshed, + in case the search produces a NULL. + + PR fortran/25077 + PR fortran/25102 + * interface.c (check_operator_interface): Throw error if the + interface assignment tries to change intrinsic type assigments + or has less than two arguments. Also, it is an error if an + interface operator contains an alternate return. + + PR fortran/24866 + * parse.c (gfc_fixup_sibling_symbols): Do not modify the symbol + if it is a dummy in the contained namespace. + + 2006-08-29 Paul Thomas + + PR fortran/28788 + * symbol.c (gfc_use_derived): Never eliminate the symbol, + following reassociation of use associated derived types. + + 2006-08-24 Paul Thomas + + PR fortran/28788 + * symbol.c (shift_types): Shift the derived type references in + formal namespaces. + (gfc_use_derived): Return if the derived type symbol is already + in another namspace. Add searches for the derived type in + sibling namespaces. + + PR fortran/28771 + * decl.c (add_init_expr_to_sym): Restore the original but + restricted to parameter arrays to fix a regression. + + 2006-08-23 Paul Thomas + + PR fortran/28788 + * gfortran.dg/used_types_4.f90: New test. + * gfortran.dg/derived_init_2.f90: Modify to check sibling + association of derived types. + * gfortran.dg/used_types_2.f90: Add module cleanup. + * gfortran.dg/used_types_3.f90: The same. + + PR fortran/28771 + * gfortran.dg/assumed_charlen_in_main.f90: Modify to check + fix of regression. + + 2006-08-20 Paul Thomas + + PR fortran/28601 + PR fortran/28630 + * gfortran.h : Eliminate gfc_dt_list structure and reference + to it in gfc_namespace. + * resolve.c (resolve_fl_derived): Remove the building of the + list of derived types for the current namespace. + * symbol.c (find_renamed_type): New function to find renamed + derived types by symbol name rather than symtree name. + (gfc_use_derived): Search parent namespace for identical + derived type and use it, even if local version is complete, + except in interface bodies. Ensure that renamed derived types + are found by call to find_renamed_type. Recurse for derived + type components. + (gfc_free_dt_list): Remove. + (gfc_free_namespace): Remove call to previous. + * trans-types.c (copy_dt_decls_ifequal): Remove. + (gfc_get_derived_type): Remove all the paraphenalia for + association of derived types, including calls to previous. + * match.c (gfc_match_allocate): Call gfc_use_derived to + associate any derived types that are being allocated. + + PR fortran/20886 + * resolve.c (resolve_actual_arglist): The passing of + a generic procedure name as an actual argument is an + error. + + PR fortran/28735 + * resolve.c (resolve_variable): Check for a symtree before + resolving references. + + PR fortran/28762 + * primary.c (match_variable): Return MATCH_NO if the symbol + is that of the program. + + PR fortran/28425 + * trans-expr.c (gfc_trans_subcomponent_assign): Translate + derived type component expressions other than another derived + type constructor. + + PR fortran/28496 + * expr.c (find_array_section): Correct errors in + the handling of a missing start value for the + index triplet in an array reference. + + PR fortran/18111 + * trans-decl.c (gfc_build_dummy_array_decl): Before resetting + reference to backend_decl, set it DECL_ARTIFICIAL. + (gfc_get_symbol_decl): Likewise for original dummy decl, when + a copy is made of an array. + (create_function_arglist): Likewise for the _entry paramter + in entry_masters. + (build_entry_thunks): Likewise for dummies in entry thunks. + + PR fortran/28771 + * decl.c (add_init_expr_to_sym): Remove setting of charlen for + an initializer of an assumed charlen variable. + + PR fortran/28660 + * trans-decl.c (generate_expr_decls): New function. + (generate_dependency_declarations): New function. + (generate_local_decl): Call previous if not either a dummy or + a declaration in an entry master. + + 2006-08-19 Erik Edelmann + + PR fortran/25217 + * resolve.c (resolve_fl_variable): Set a default initializer for + derived types with INTENT(OUT) even if 'flag' is true. + * trans-expr.c (gfc_conv_function_call): Insert code to + reinitialize INTENT(OUT) arguments of derived type with default + initializers. + + 2006-08-15 Jerry DeLisle + + PR fortran/25828 + * gfortran.h: Add new pointer for stream position to st_inquire. + Rename gfc_large_io_int_kind to gfc_intio_kind. + * trans-types.c (gfc_init_kinds): use gfc_intio_kind. + * io.c: Add new IO tag for file position going in and another for out. + (match_dt_element): Match new tag_spos. + (gfc_resolve_dt): Resolve new tag_spos. + (gfc_free_inquire): Free inquire->strm_pos. + (match_inquire_element): Match new tag_strm_out. + (gfc_resolve_inquire): Resolve new tag_strm_out. + * trans-io.c: Rename IOPARM_type_large_io_int to IOPARM_type_intio. + (gfc_build_st_parameter): Same. + (gfc_build_io_library_fndecls) Same. and add build pointer type pintio. + (gfc_trans_inquire): Translate strm_pos for inquire. + * ioparm.def: Reorder flags to accomodate addition of new inquire + flag for strm_pos_out and add it in.2006-08-20 Erik Edelmann + + PR fortran/25217 + * resolve.c (resolve_fl_variable): Set a default initializer for + derived types with INTENT(OUT) even if 'flag' is true. + * trans-expr.c (gfc_conv_function_call): Insert code to + reinitialize INTENT(OUT) arguments of derived type with default + initializers. + + 2006-08-14 Asher Langton + + * decl.c (match_old_style_init): Add data attribute to symbol. + + 2006-08-06 Paul Thomas + + PR fortran/28590 + * parse.c (parse_derived): Remove the test for sequence type + components of a sequence type. + * resolve.c (resolve_fl_derived): Put the test here so that + pointer components are tested. + + 2006-08-05 Steven G. Kargl + + PR fortran/28548 + * resolve.c(resolve_elemental_actual): Add flags.h to use -pedantic + and exclude conversion functions in conditional. Change gfc_error + to gfc_warning. + (warn_unused_label) Rename to ... + (warn_unused_fortran_label) avoid warn_unused_label in flags.h. + + PR fortran/27981 + * match.c (gfc_match_if): Handle errors in assignment in simple if. + + 2006-07-26 Francois-Xavier Coudert + Daniel Franke + + * intrinsic.c (add_subroutines): Add ITIME and IDATE. + * intrinsic.h (gfc_check_itime_idate,gfc_resolve_idate, + fc_resolve_itime): New protos. + * iresolve.c (gfc_resolve_itime, gfc_resolve_idate): New functions. + * check.c (gfc_check_itime_idate): New function. + * intrinsic.texi: Document the new intrinsics. + + 2006-07-25 Steven G. Kargl + + PR fortran/28439 + *trans-stmt.c (gfc_trans_arithmetic_if): Evaluate the condition once. + + 2006-07-24 Francois-Xavier Coudert + + PR fortran/28129 + * trans-array.c (gfc_trans_array_bound_check): Add a locus + argument, and use it in the error messages. + (gfc_conv_array_index_offset): Donc perform bounds checking on + the last dimension of assumed-size arrays. + + 2006-07-24 Francois-Xavier Coudert + + PR fortran/27874 + * trans-stmt.c (compute_inner_temp_size): Don't perform bounds + checking when calculating the bounds of scalarization. + + 2006-07-24 Francois-Xavier Coudert + + PR fortran/20892 + * interface.c (gfc_match_interface): Don't allow dummy procedures + to have a generic interface. + + 2006-07-16 Paul Thomas + + PR fortran/28384 + * trans-common.c (translate_common): If common_segment is NULL + emit error that common block does not exist. + + PR fortran/20844 + * io.c (check_io_constraints): It is an error if an ADVANCE + specifier appears without an explicit format. + + PR fortran/28201 + * resolve.c (resolve_generic_s): For a use_associated function, + do not search for an alternative symbol in the parent name + space. + + PR fortran/20893 + * resolve.c (resolve_elemental_actual): New function t combine + all the checks of elemental procedure actual arguments. In + addition, check of array valued optional args(this PR) has + been added. + (resolve_function, resolve_call): Remove parts that treated + elemental procedure actual arguments and call the above. + + PR fortran/28353 + * trans-expr.c (gfc_conv_aliased_arg): Missing formal arg means + that intent is INOUT (fixes regression). + + PR fortran/25097 + * check.c (check_present): The only permitted reference is a + full array reference. + + PR fortran/20903 + * decl.c (variable_decl): Add error if a derived type is not + from the current namespace if the namespace is an interface + body. + + 2006-07-16 Thomas Koenig + + PR fortran/27980 + Backport from mainline + * trans-array.h (gfc_trans_allocate_temp_array): Add bool + argument. + * trans-array.c (gfc_trans_allocate_temp_array): Add extra + argument "function" to show if we are translating a function. + If we are translating a function, perform checks whether + the size along any argument is negative. In that case, + allocate size 0. + (gfc_trans_array_constructor): Add funciton argument (as + false) to gfc_trans_allocate_temp_array. + (gfc_conv_loop_setup): Likewise. + * trans-expr.c (gfc_trans_function_call): Add funciton + argument (as true) to gfc_trans_allocate_temp_array. + * trans-stmt.c (gfc_conv_elemental_dependencies): Add funciton + argument (as false) to gfc_trans_allocate_temp_array. + * trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): + Likewise. + + 2006-07-11 Feng Wang + + PR fortran/28213 + * trans-io.c (transfer_expr): Deal with Hollerith constants used in + I/O list. + + 2006-07-07 Paul Thomas + + PR fortran/28237 + PR fortran/23420 + * io.c (resolve_tag): Any integer that is not an assigned + variable is an error. + + 2006-07-06 Paul Thomas + + PR fortran/28174 + * trans-array.c (gfc_conv_expr_descriptor): When building temp, + ensure that the substring reference uses a new charlen. + * trans-expr.c (gfc_conv_aliased_arg): Add the formal intent to + the argument list, lift the treatment of missing string lengths + from the above and implement the use of the intent. + (gfc_conv_function_call): Add the extra argument to the call to + the above. + + PR fortran/28167 + * trans-array.c (get_array_ctor_var_strlen): Treat a constant + substring reference. + * array.c (gfc_resolve_character_array_constructor): Remove + static attribute and add the gfc_ prefix, make use of element + charlens for the expression and pick up constant string lengths + for expressions that are not themselves constant. + * gfortran.h : resolve_character_array_constructor prototype + added. + * resolve.c (gfc_resolve_expr): Call resolve_character_array_ + constructor again after expanding the constructor, to ensure + that the character length is passed to the expression. + + 2006-07-03 Francois-Xavier Coudert + + * iresolve.c (gfc_resolve_cpu_time, gfc_resolve_random_number): + Remove ATTRIBUTE_UNUSED for used argument. + + 2006-07-03 Francois-Xavier Coudert + + * intrinsic.texi: Document new intrinsics. + + 2006-07-02 Francois-Xavier Coudert + + PR fortran/28094 + * trans-intrinsic.c (gfc_conv_intrinsic_mod): Support cases where + there is no integer kind equal to the resulting real kind. + * intrinsic.c (add_functions): MODULO is not allowed as an actual + argument. + + 2006-07-02 Francois-Xavier Coudert + + PR fortran/27965 + * trans-array.c (gfc_conv_ss_startstride): Correct the runtime + conditions for bounds-checking. Check for nonzero stride. + Don't check the last dimension of assumed-size arrays. Fix the + dimension displayed in the error message. + + 2006-07-02 Francois-Xavier Coudert + + PR fortran/26801 + * trans-intrinsic.c (gfc_conv_associated): Use pre and post blocks + of the scalarization expression. + + 2006-07-02 Francois-Xavier Coudert + + PR fortran/28081 + * resolve.c (resolve_substring): Don't issue out-of-bounds + error messages when the range has zero size. + + 2006-07-02 Francois-Xavier Coudert + + PR fortran/23862 + * lang-specs.h (f95-cpp-input): Pass -ffree-form to f951 unless + -ffixed-form is explicitly specified. + + 2006-06-30 Asher Langton + + PR fortran/24748 + * primary.c (gfc_match_rvalue): Don't call + match_substring for implicit non-character types. + + 2006-06-27 Jerry DeLisle + + PR fortran/19310 + PR fortran/19904 + * arith.c (gfc_range_check): Return ARITH_OK if -fno-range-check. Add + return of ARITH_NAN, ARITH_UNDERFLOW, and ARITH_OVERFLOW. + (gfc_arith_divide): If -fno-range-check allow mpfr to divide by zero. + * gfortran.h (gfc_option_t): Add new flag. + * invoke.texi: Document new flag. + * lang.opt: Add option -frange-check. + * options.c (gfc_init_options): Initialize new flag. + (gfc_handle_options): Set flag if invoked. + * simplify.c (range_check): Add error messages for + overflow, underflow, and other errors. + * trans-const.c (gfc_conv_mpfr_to_tree): Build NaN and Inf from mpfr + result. + + 2006-06-25 Paul Thomas + + PR fortran/25056 + * interface.c (compare_actual_formal): Signal an error if the formal + argument is a pure procedure and the actual is not pure. + + PR fortran/27554 + * resolve.c (resolve_actual_arglist): If the type of procedure + passed as an actual argument is not already declared, see if it is + an intrinsic. + + PR fortran/25073 + * resolve.c (resolve_select): Use bits 1 and 2 of a new int to + keep track of the appearance of constant logical case expressions. + Signal an error is either value appears more than once. + + PR fortran/20874 + * resolve.c (resolve_fl_procedure): Signal an error if an elemental + function is not scalar valued. + + PR fortran/20867 + * match.c (recursive_stmt_fcn): Perform implicit typing of variables. + + PR fortran/22038 + * match.c (match_forall_iterator): Mark new variables as + FL_UNKNOWN if the match fails. + + PR fortran/28119 + * match.c (gfc_match_forall): Remove extraneous call to + gfc_match_eos. + + PR fortran/25072 + * resolve.c (resolve_code, resolve_function): Rework + forall_flag scheme so that it is set and has a value of + 2, when the code->expr (ie. the forall mask) is resolved. + This is used to change "block" to "mask" in the non-PURE + error message. + + 2006-06-24 Paul Thomas + + PR fortran/28118 + * trans-array.c (gfc_conv_expr_descriptor): When building temp, + use the substring reference to calculate the length if the + expression does not have a charlen. + + 2006-06-23 Paul Thomas + + PR fortran/25049 + PR fortran/25050 + * check.c (non_init_transformational): New function. + (find_substring_ref): New function to signal use of disallowed + transformational intrinsic in an initialization expression. + (gfc_check_all_any): Call previous if initialization expr. + (gfc_check_count): The same. + (gfc_check_cshift): The same. + (gfc_check_dot_product): The same. + (gfc_check_eoshift): The same. + (gfc_check_minloc_maxloc): The same. + (gfc_check_minval_maxval): The same. + (gfc_check_gfc_check_product_sum): The same. + (gfc_check_pack): The same. + (gfc_check_spread): The same. + (gfc_check_transpose): The same. + (gfc_check_unpack): The same. + + PR fortran/18769 + *intrinsic.c (add_functions): Add gfc_simplify_transfer. + *intrinsic.h : Add prototype for gfc_simplify_transfer. + *simplify.c (gfc_simplify_transfer) : New function to act as + placeholder for eventual implementation. Emit error for now. + + PR fortran/16206 + * expr.c (find_array_element): Eliminate condition on length of + offset. Add bounds checking. Rearrange exit. Return try and + put gfc_constructor result as an argument. + (find_array_section): New function. + (find_substring_ref): New function. + (simplify_const_ref): Add calls to previous. + (simplify_parameter_variable): Return on NULL expr. + (gfc_simplify_expr): Only call gfc_expand_constructor for full + arrays. + + PR fortran/20876 + * match.c (gfc_match_forall): Add missing locus to gfc_code. + + 2006-06-21 Steven G. Kargl + + * simplify.c (gfc_simplify_rrspacing): Initialize and clear mpfr_t + variable. + + 2006-06-20 Francois-Xavier Coudert + + PR fortran/27958 + * trans-expr.c (gfc_conv_substring): If the substring start is + greater than its end, the length of the substring is zero, and + not negative. + (gfc_trans_string_copy): Don't generate a call to + _gfortran_copy_string when destination length is zero. + + 2006-06-20 Francois-Xavier Coudert + + PR libfortran/27895 + * resolve.c (compute_last_value_for_triplet): New function. + (check_dimension): Correctly handle zero-sized array sections. + Add checking on last element of array sections. + + 2006-06-20 Francois-Xavier Coudert + + * trans.c (gfc_msg_bounds, gfc_msg_fault, gfc_msg_wrong_return): + Add strings for common runtime error messages. + (gfc_trans_runtime_check): Add a locus argument, use a string + and not a string tree for the message. + * trans.h (gfc_trans_runtime_check): Change prototype accordingly. + (gfc_msg_bounds, gfc_msg_fault, gfc_msg_wrong_return): Add proto. + * trans-const.c (gfc_strconst_bounds, gfc_strconst_fault, + gfc_strconst_wrong_return, gfc_strconst_current_filename): Remove. + (gfc_init_constants): Likewise. + * trans-const.h: Likewise. + * trans-decl.c (gfc_build_builtin_function_decls): Call to + _gfortran_runtime_error has only one argument, the message string. + * trans-array.h (gfc_conv_array_ref): Add a symbol argument and a + locus. + * trans-array.c (gfc_trans_array_bound_check): Build precise + error messages. + (gfc_conv_array_ref): Use the new symbol argument and the locus + to build more precise error messages. + (gfc_conv_ss_startstride): More precise error messages. + * trans-expr.c (gfc_conv_variable): Give symbol reference and + locus to gfc_conv_array_ref. + (gfc_conv_function_call): Use the new prototype for + gfc_trans_runtime_check. + * trans-stmt.c (gfc_trans_goto): Build more precise error message. + * trans-io.c (set_string): Likewise. + * trans-intrinsic.c (gfc_conv_intrinsic_bound): Use new prototype + for gfc_trans_runtime_check. + + 2006-06-20 Thomas Koenig + + PR fortran/27715 + * arith.c: Cast the characters from the strings to unsigned + char to avoid values less than 0 for extended ASCII. + + 2006-06-15 Asher Langton + + PR fortran/27786 + * trans-array.c (gfc_conv_array_ref): Eliminate bounds checking + for assumed-size Cray pointees. + + 2006-06-12 Paul Thomas + + PR fortran/24558 + PR fortran/20877 + PR fortran/25047 + * decl.c (get_proc_name): Add new argument to flag that a + module function entry is being treated. If true, correct + error condition, add symtree to module namespace and add + a module procedure. + (gfc_match_function_decl, gfc_match_entry, + gfc_match_subroutine): Use the new argument in calls to + get_proc_name. + * resolve.c (resolve_entries): ENTRY symbol reference to + to master entry namespace if a module function. + * trans-decl.c (gfc_create_module_variable): Return if + the symbol is an entry. + + PR fortran/23091 + * resolve.c (resolve_fl_variable): Error if an automatic + object has the SAVE attribute. + + PR fortran/24168 + * expr.c (simplify_intrinsic_op): Transfer the rank and + the locus to the simplified expression. + + PR fortran/25090 + PR fortran/25058 + * gfortran.h : Add int entry_id to gfc_symbol. + * resolve.c : Add static variables current_entry_id and + specification_expr. + (resolve_variable): During code resolution, check if a + reference to a dummy variable in an executable expression + is preceded by its appearance as a parameter in an entry. + Likewise check its specification expressions. + (resolve_code): Update current_entry_id on EXEC_ENTRY. + (resolve_charlen, resolve_fl_variable): Set and reset + specifiaction_expr. + (is_non_constant_shape_array): Do not return on detection + of a variable but continue to resolve all the expressions. + (resolve_codes): set current_entry_id to an out of range + value. + + 2006-06-06 Paul Thomas + + PR fortran/27897 + * match.c (gfc_match_common): Fix code typo. Remove + sym->name, since sym is NULL, and replace with name. + + 2006-06-05 Paul Thomas + + PR fortran/14067 + * data.c (create_character_intializer): Add warning message + for truncated string. + + PR fortran/16943 + * symbol.c : Include flags.h. + (gfc_add_type): If a procedure and types are the same do not + throw an error unless standard is less than gnu or pedantic. + + PR fortran/20839 + * parse.c (parse_do_block): Error if named block do construct + does not have a named enddo. + + PR fortran/27655 + * check.c (gfc_check_associated): Pick up EXPR_NULL for pointer + as well as target and put error return at end of function. + + 2006-06-03 Francois-Xavier Coudert + + PR fortran/19777 + * trans-array.c (gfc_conv_array_ref): Don't perform out-of-bounds + checking for assumed-size arrrays. + + 2006-06-03 Francois-Xavier Coudert + + PR fortran/27524 + * trans-array.c (gfc_trans_dummy_array_bias): Don't use stride as + a temporary variable when -fbounds-check is enabled, since its + value will be needed later. + + 2006-06-01 Paul Thomas + + PR fortran/25098 + PR fortran/25147 + * interface.c (compare_parameter): Return 1 if the actual arg + is external and the formal is a procedure. + (compare_actual_formal): If the actual argument is a variable + and the formal a procedure, this an error. If a gsymbol exists + for a procedure of the same name, this is not yet resolved and + the error is cleared. + + * trans-intrinsic.c (gfc_conv_associated): Make provision for + zero array length or zero string length contingent on presence + of target, for consistency with standard. + + 2006-05-31 Thomas Koenig + + PR fortran/23151 + Backport from mainline. + * io.c (match_io): print (1,*) is an error. + + 2006-05-30 H.J. Lu + + PR fortran/27662 + Backport from mainline + 2006-05-18 H.J. Lu + * trans-array.c (gfc_conv_expr_descriptor): Don't zero the + first stride to indicate a temporary. + * trans-expr.c (gfc_conv_function_call): Likewise. + + 2005-05-28 Thomas Koenig + + PR fortran/27470 + Backport from trunk. + * trans-array.c(gfc_array_allocate): If ref->next exists + that is if there is a statement like ALLOCATE(foo%bar(2)), + F95 rules require that bar should be a pointer. + + 2006-05-28 Paul Thomas + + PR fortran/25082 + * resolve.c (resolve_code): Add error condition that the return + expression must be scalar. + + PR fortran/27411 + * matchexp.c (gfc_get_parentheses): New function. + (match_primary): Remove inline code and call above. + * gfortran.h: Provide prototype for gfc_get_parentheses. + * resolve.c (resolve_array_ref): Call the above, when start is a + derived type variable array reference. + + PR fortran/27613 + * primary.c (gfc_match_rvalue): Test if symbol represents a + direct recursive function reference. Error if array valued, + go to function0 otherwise. + + PR fortran/25746 + * interface.c (gfc_extend_assign): Use new EXEC_ASSIGN_CALL. + * gfortran.h : Put EXEC_ASSIGN_CALL in enum. + * trans-stmt.c (gfc_conv_elemental_dependencies): New function. + (gfc_trans_call): Call it. Add new boolian argument to flag + need for dependency checking. Assert intent OUT and IN for arg1 + and arg2. + (gfc_trans_forall_1): Use new code EXEC_ASSIGN_CALL. + trans-stmt.h : Modify prototype of gfc_trans_call. + trans.c (gfc_trans_code): Add call for EXEC_ASSIGN_CALL. + st.c (gfc_free_statement): Free actual for EXEC_ASSIGN_CALL. + * dependency.c (gfc_check_fncall_dependency): Don't check other + against itself. + + PR fortran/27584 + * check.c (gfc_check_associated): Replace NULL assert with an + error message, since it is possible to generate bad code that + has us fall through to here.. + + PR fortran/19015 + * iresolve.c (maxloc, minloc): If DIM is not present, pass the + rank of ARRAY as the shape of the result. Otherwise, pass the + shape of ARRAY, less the dimension DIM. + (maxval, minval): The same, when DIM is present, otherwise no + change. + + PR fortran/27709 + * resolve.c (find_array_spec): Add gfc_symbol, derived, and + use to track repeated component references. + + PR fortran/27155 + PR fortran/27449 + * trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Use + se->string_length throughout and use memcpy to populate the + expression returned to the scalarizer. + (gfc_size_in_bytes): New function. + + * trans-intrinsic.c (gfc_conv_associated): If pointer in first + arguments has zero array length of zero string length, return + false. + + 2006-05-27 Francois-Xavier Coudert + Feng Wang + + PR fortran/27552 + * dump-parse-tree.c (gfc_show_expr): Deal with Hollerith constants. + * data.c (create_character_intializer): Set from_H flag if character is + initialized by Hollerith constant. + + 2006-05-27 Francois-Xavier Coudert + + PR fortran/27320 + * dump-parse-tree.c (gfc_show_code_node): Try harder to find the + called procedure name. + + 2006-05-27 Francois-Xavier Coudert + + PR fortran/26551 + * resolve.c (resolve_call, resolve_function): Issue an error + if a function or subroutine call is recursive but the function or + subroutine wasn't declared as such. + 2006-05-24 Release Manager * GCC 4.1.1 released. *************** *** 108,114 **** but not here in 4.1 because the trees have diverged too much. Manifestly correct, so applied anyway. ! PR fortran/18803 PR fortran/25669 PR fortran/26834 * trans_intrinsic.c (gfc_walk_intrinsic_bound): Set --- 1164,1170 ---- but not here in 4.1 because the trees have diverged too much. Manifestly correct, so applied anyway. ! PR fortran/18003 PR fortran/25669 PR fortran/26834 * trans_intrinsic.c (gfc_walk_intrinsic_bound): Set diff -Nrcpad gcc-4.1.1/gcc/fortran/arith.c gcc-4.1.2/gcc/fortran/arith.c *** gcc-4.1.1/gcc/fortran/arith.c Sun Feb 12 18:31:40 2006 --- gcc-4.1.2/gcc/fortran/arith.c Wed Jun 28 05:36:08 2006 *************** gfc_check_real_range (mpfr_t p, int kind *** 379,390 **** mpfr_init (q); mpfr_abs (q, p, GFC_RND_MODE); ! if (mpfr_sgn (q) == 0) retval = ARITH_OK; else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0) ! retval = ARITH_OVERFLOW; else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0) ! retval = ARITH_UNDERFLOW; else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0) { /* MPFR operates on a numbers with a given precision and enormous --- 379,414 ---- mpfr_init (q); mpfr_abs (q, p, GFC_RND_MODE); ! if (mpfr_inf_p (p)) ! { ! if (gfc_option.flag_range_check == 0) ! retval = ARITH_OK; ! else ! retval = ARITH_OVERFLOW; ! } ! else if (mpfr_nan_p (p)) ! { ! if (gfc_option.flag_range_check == 0) ! retval = ARITH_OK; ! else ! retval = ARITH_NAN; ! } ! else if (mpfr_sgn (q) == 0) retval = ARITH_OK; else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0) ! { ! if (gfc_option.flag_range_check == 0) ! retval = ARITH_OK; ! else ! retval = ARITH_OVERFLOW; ! } else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0) ! { ! if (gfc_option.flag_range_check == 0) ! retval = ARITH_OK; ! else ! retval = ARITH_UNDERFLOW; ! } else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0) { /* MPFR operates on a numbers with a given precision and enormous *************** gfc_range_check (gfc_expr * e) *** 564,582 **** case BT_REAL: rc = gfc_check_real_range (e->value.real, e->ts.kind); if (rc == ARITH_UNDERFLOW) ! mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); break; case BT_COMPLEX: rc = gfc_check_real_range (e->value.complex.r, e->ts.kind); if (rc == ARITH_UNDERFLOW) ! mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE); ! if (rc == ARITH_OK || rc == ARITH_UNDERFLOW) ! { ! rc = gfc_check_real_range (e->value.complex.i, e->ts.kind); ! if (rc == ARITH_UNDERFLOW) ! mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE); ! } break; --- 588,616 ---- case BT_REAL: rc = gfc_check_real_range (e->value.real, e->ts.kind); if (rc == ARITH_UNDERFLOW) ! mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); ! if (rc == ARITH_OVERFLOW) ! mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real)); ! if (rc == ARITH_NAN) ! mpfr_set_nan (e->value.real); break; case BT_COMPLEX: rc = gfc_check_real_range (e->value.complex.r, e->ts.kind); if (rc == ARITH_UNDERFLOW) ! mpfr_set_ui (e->value.complex.r, 0, GFC_RND_MODE); ! if (rc == ARITH_OVERFLOW) ! mpfr_set_inf (e->value.complex.r, mpfr_sgn (e->value.complex.r)); ! if (rc == ARITH_NAN) ! mpfr_set_nan (e->value.complex.r); ! ! rc = gfc_check_real_range (e->value.complex.i, e->ts.kind); ! if (rc == ARITH_UNDERFLOW) ! mpfr_set_ui (e->value.complex.i, 0, GFC_RND_MODE); ! if (rc == ARITH_OVERFLOW) ! mpfr_set_inf (e->value.complex.i, mpfr_sgn (e->value.complex.i)); ! if (rc == ARITH_NAN) ! mpfr_set_nan (e->value.complex.i); break; *************** gfc_arith_divide (gfc_expr * op1, gfc_ex *** 813,820 **** break; case BT_REAL: ! /* FIXME: MPFR correctly generates NaN. This may not be needed. */ ! if (mpfr_sgn (op2->value.real) == 0) { rc = ARITH_DIV0; break; --- 847,854 ---- break; case BT_REAL: ! if (mpfr_sgn (op2->value.real) == 0 ! && gfc_option.flag_range_check == 1) { rc = ARITH_DIV0; break; *************** gfc_arith_divide (gfc_expr * op1, gfc_ex *** 825,833 **** break; case BT_COMPLEX: - /* FIXME: MPFR correctly generates NaN. This may not be needed. */ if (mpfr_sgn (op2->value.complex.r) == 0 ! && mpfr_sgn (op2->value.complex.i) == 0) { rc = ARITH_DIV0; break; --- 859,867 ---- break; case BT_COMPLEX: if (mpfr_sgn (op2->value.complex.r) == 0 ! && mpfr_sgn (op2->value.complex.i) == 0 ! && gfc_option.flag_range_check == 1) { rc = ARITH_DIV0; break; *************** gfc_compare_string (gfc_expr * a, gfc_ex *** 1133,1140 **** for (i = 0; i < len; i++) { ! ac = (i < alen) ? a->value.character.string[i] : ' '; ! bc = (i < blen) ? b->value.character.string[i] : ' '; if (xcoll_table != NULL) { --- 1167,1176 ---- for (i = 0; i < len; i++) { ! /* We cast to unsigned char because default char, if it is signed, ! would lead to ac<0 for string[i] > 127. */ ! ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' '); ! bc = (unsigned char) ((i < blen) ? b->value.character.string[i] : ' '); if (xcoll_table != NULL) { diff -Nrcpad gcc-4.1.1/gcc/fortran/array.c gcc-4.1.2/gcc/fortran/array.c *** gcc-4.1.1/gcc/fortran/array.c Fri Apr 7 06:02:05 2006 --- gcc-4.1.2/gcc/fortran/array.c Thu Jul 6 15:35:24 2006 *************** resolve_array_list (gfc_constructor * p) *** 1518,1525 **** not specified character length, update character length to the maximum of its element constructors' length. */ ! static void ! resolve_character_array_constructor (gfc_expr * expr) { gfc_constructor * p; int max_length; --- 1518,1525 ---- not specified character length, update character length to the maximum of its element constructors' length. */ ! void ! gfc_resolve_character_array_constructor (gfc_expr * expr) { gfc_constructor * p; int max_length; *************** resolve_character_array_constructor (gfc *** 1531,1550 **** if (expr->ts.cl == NULL) { expr->ts.cl = gfc_get_charlen (); expr->ts.cl->next = gfc_current_ns->cl_list; gfc_current_ns->cl_list = expr->ts.cl; } if (expr->ts.cl->length == NULL) { /* Find the maximum length of the elements. Do nothing for variable array ! constructor. */ for (p = expr->value.constructor; p; p = p->next) ! if (p->expr->expr_type == EXPR_CONSTANT) ! max_length = MAX (p->expr->value.character.length, max_length); ! else ! return; if (max_length != -1) { --- 1531,1583 ---- if (expr->ts.cl == NULL) { + for (p = expr->value.constructor; p; p = p->next) + if (p->expr->ts.cl != NULL) + { + /* Ensure that if there is a char_len around that it is + used; otherwise the middle-end confuses them! */ + expr->ts.cl = p->expr->ts.cl; + goto got_charlen; + } + expr->ts.cl = gfc_get_charlen (); expr->ts.cl->next = gfc_current_ns->cl_list; gfc_current_ns->cl_list = expr->ts.cl; } + got_charlen: + if (expr->ts.cl->length == NULL) { /* Find the maximum length of the elements. Do nothing for variable array ! constructor, unless the character length is constant or there is a ! constant substring reference. */ ! for (p = expr->value.constructor; p; p = p->next) ! { ! gfc_ref *ref; ! for (ref = p->expr->ref; ref; ref = ref->next) ! if (ref->type == REF_SUBSTRING ! && ref->u.ss.start->expr_type == EXPR_CONSTANT ! && ref->u.ss.end->expr_type == EXPR_CONSTANT) ! break; ! ! if (p->expr->expr_type == EXPR_CONSTANT) ! max_length = MAX (p->expr->value.character.length, max_length); ! ! else if (ref) ! max_length = MAX ((int)(mpz_get_ui (ref->u.ss.end->value.integer) ! - mpz_get_ui (ref->u.ss.start->value.integer)) ! + 1, max_length); ! ! else if (p->expr->ts.cl && p->expr->ts.cl->length ! && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT) ! max_length = MAX ((int)mpz_get_si (p->expr->ts.cl->length->value.integer), ! max_length); ! ! else ! return; ! } if (max_length != -1) { *************** resolve_character_array_constructor (gfc *** 1552,1558 **** expr->ts.cl->length = gfc_int_expr (max_length); /* Update the element constructors. */ for (p = expr->value.constructor; p; p = p->next) ! gfc_set_constant_character_len (max_length, p->expr); } } } --- 1585,1592 ---- expr->ts.cl->length = gfc_int_expr (max_length); /* Update the element constructors. */ for (p = expr->value.constructor; p; p = p->next) ! if (p->expr->expr_type == EXPR_CONSTANT) ! gfc_set_constant_character_len (max_length, p->expr); } } } *************** gfc_resolve_array_constructor (gfc_expr *** 1568,1574 **** if (t == SUCCESS) t = gfc_check_constructor_type (expr); if (t == SUCCESS && expr->ts.type == BT_CHARACTER) ! resolve_character_array_constructor (expr); return t; } --- 1602,1608 ---- if (t == SUCCESS) t = gfc_check_constructor_type (expr); if (t == SUCCESS && expr->ts.type == BT_CHARACTER) ! gfc_resolve_character_array_constructor (expr); return t; } diff -Nrcpad gcc-4.1.1/gcc/fortran/check.c gcc-4.1.2/gcc/fortran/check.c *** gcc-4.1.1/gcc/fortran/check.c Sat Mar 4 22:21:52 2006 --- gcc-4.1.2/gcc/fortran/check.c Wed Jul 26 09:44:59 2006 *************** dim_rank_check (gfc_expr * dim, gfc_expr *** 377,382 **** --- 377,394 ---- return SUCCESS; } + /* Error return for transformational intrinsics not allowed in + initalization expressions. */ + + static try + non_init_transformational (void) + { + gfc_error ("transformational intrinsic '%s' at %L is not permitted " + "in an initialization expression", gfc_current_intrinsic, + gfc_current_intrinsic_where); + return FAILURE; + } + /***** Check functions *****/ /* Check subroutine suitable for intrinsics taking a real argument and *************** gfc_check_all_any (gfc_expr * mask, gfc_ *** 438,443 **** --- 450,458 ---- if (dim_check (dim, 1, 1) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_associated (gfc_expr * pointer *** 498,508 **** --- 513,528 ---- symbol_attribute attr; int i; try t; + locus *where; + + where = &pointer->where; if (pointer->expr_type == EXPR_VARIABLE) attr = gfc_variable_attr (pointer, NULL); else if (pointer->expr_type == EXPR_FUNCTION) attr = pointer->symtree->n.sym->attr; + else if (pointer->expr_type == EXPR_NULL) + goto null_arg; else gcc_assert (0); /* Pointer must be a variable or a function. */ *************** gfc_check_associated (gfc_expr * pointer *** 518,537 **** if (target == NULL) return SUCCESS; if (target->expr_type == EXPR_NULL) ! { ! gfc_error ("NULL pointer at %L is not permitted as actual argument " ! "of '%s' intrinsic function", ! &target->where, gfc_current_intrinsic); ! return FAILURE; ! } if (target->expr_type == EXPR_VARIABLE) attr = gfc_variable_attr (target, NULL); else if (target->expr_type == EXPR_FUNCTION) attr = target->symtree->n.sym->attr; else ! gcc_assert (0); /* Target must be a variable or a function. */ if (!attr.pointer && !attr.target) { --- 538,558 ---- if (target == NULL) return SUCCESS; + where = &target->where; if (target->expr_type == EXPR_NULL) ! goto null_arg; if (target->expr_type == EXPR_VARIABLE) attr = gfc_variable_attr (target, NULL); else if (target->expr_type == EXPR_FUNCTION) attr = target->symtree->n.sym->attr; else ! { ! gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer " ! "or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1], ! gfc_current_intrinsic, &target->where); ! return FAILURE; ! } if (!attr.pointer && !attr.target) { *************** gfc_check_associated (gfc_expr * pointer *** 559,564 **** --- 580,592 ---- } } return t; + + null_arg: + + gfc_error ("NULL pointer at %L is not permitted as actual argument " + "of '%s' intrinsic function", where, gfc_current_intrinsic); + return FAILURE; + } *************** gfc_check_count (gfc_expr * mask, gfc_ex *** 710,715 **** --- 738,746 ---- if (dim_check (dim, 1, 1) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_cshift (gfc_expr * array, gfc_ *** 733,738 **** --- 764,772 ---- if (dim_check (dim, 2, 1) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_dot_product (gfc_expr * vector *** 834,839 **** --- 868,876 ---- return FAILURE; } + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_eoshift (gfc_expr * array, gfc *** 869,874 **** --- 906,914 ---- if (dim_check (dim, 1, 1) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_matmul (gfc_expr * matrix_a, g *** 1531,1536 **** --- 1571,1579 ---- return FAILURE; } + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_minloc_maxloc (gfc_actual_argl *** 1591,1596 **** --- 1634,1642 ---- return FAILURE; } + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_minval_maxval (gfc_actual_argl *** 1659,1664 **** --- 1705,1713 ---- || array_check (ap->expr, 0) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return check_reduction (ap); } *************** gfc_check_product_sum (gfc_actual_arglis *** 1670,1675 **** --- 1719,1727 ---- || array_check (ap->expr, 0) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return check_reduction (ap); } *************** gfc_check_pack (gfc_expr * array, gfc_ex *** 1767,1772 **** --- 1819,1827 ---- /* TODO: More constraints here. */ } + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_present (gfc_expr * a) *** 1811,1816 **** --- 1866,1887 ---- return FAILURE; } + /* 13.14.82 PRESENT(A) + ...... + Argument. A shall be the name of an optional dummy argument that is accessible + in the subprogram in which the PRESENT function reference appears... */ + + if (a->ref != NULL + && !(a->ref->next == NULL + && a->ref->type == REF_ARRAY + && a->ref->u.ar.type == AR_FULL)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a sub-" + "object of '%s'", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic, &a->where, sym->name); + return FAILURE; + } + return SUCCESS; } *************** gfc_check_spread (gfc_expr * source, gfc *** 2138,2143 **** --- 2209,2217 ---- if (scalar_check (ncopies, 2) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_transpose (gfc_expr * matrix) *** 2353,2358 **** --- 2427,2435 ---- if (rank_check (matrix, 0, 2) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_unpack (gfc_expr * vector, gfc *** 2391,2396 **** --- 2468,2476 ---- if (same_type_check (vector, 0, field, 2) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } *************** gfc_check_hostnm_sub (gfc_expr * name, g *** 2972,2977 **** --- 3052,3079 ---- try + gfc_check_itime_idate (gfc_expr * values) + { + if (array_check (values, 0) == FAILURE) + return FAILURE; + + if (rank_check (values, 0, 1) == FAILURE) + return FAILURE; + + if (variable_check (values, 0) == FAILURE) + return FAILURE; + + if (type_check (values, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE) + return FAILURE; + + return SUCCESS; + } + + + try gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name) { if (scalar_check (unit, 0) == FAILURE) diff -Nrcpad gcc-4.1.1/gcc/fortran/data.c gcc-4.1.2/gcc/fortran/data.c *** gcc-4.1.1/gcc/fortran/data.c Sun Nov 6 20:05:12 2005 --- gcc-4.1.2/gcc/fortran/data.c Fri Nov 10 21:52:00 2006 *************** create_character_intializer (gfc_expr * *** 155,161 **** init->expr_type = EXPR_CONSTANT; init->ts = *ts; ! dest = gfc_getmem (len); init->value.character.length = len; init->value.character.string = dest; /* Blank the string if we're only setting a substring. */ --- 155,162 ---- init->expr_type = EXPR_CONSTANT; init->ts = *ts; ! dest = gfc_getmem (len + 1); ! dest[len] = '\0'; init->value.character.length = len; init->value.character.string = dest; /* Blank the string if we're only setting a substring. */ *************** create_character_intializer (gfc_expr * *** 167,179 **** if (ref) { gcc_assert (ref->type == REF_SUBSTRING); /* Only set a substring of the destination. Fortran substring bounds are one-based [start, end], we want zero based [start, end). */ ! gfc_extract_int (ref->u.ss.start, &start); start--; ! gfc_extract_int (ref->u.ss.end, &end); } else { --- 168,193 ---- if (ref) { + gfc_expr *start_expr, *end_expr; + gcc_assert (ref->type == REF_SUBSTRING); /* Only set a substring of the destination. Fortran substring bounds are one-based [start, end], we want zero based [start, end). */ ! start_expr = gfc_copy_expr (ref->u.ss.start); ! end_expr = gfc_copy_expr (ref->u.ss.end); ! ! if ((gfc_simplify_expr (start_expr, 1) == FAILURE) ! || (gfc_simplify_expr (end_expr, 1)) == FAILURE) ! { ! gfc_error ("failure to simplify substring reference in DATA" ! "statement at %L", &ref->u.ss.start->where); ! return NULL; ! } ! ! gfc_extract_int (start_expr, &start); start--; ! gfc_extract_int (end_expr, &end); } else { *************** create_character_intializer (gfc_expr * *** 185,197 **** /* Copy the initial value. */ len = rvalue->value.character.length; if (len > end - start) ! len = end - start; memcpy (&dest[start], rvalue->value.character.string, len); /* Pad with spaces. Substrings will already be blanked. */ if (len < end - start && ref == NULL) memset (&dest[start + len], ' ', end - (start + len)); return init; } --- 199,219 ---- /* Copy the initial value. */ len = rvalue->value.character.length; if (len > end - start) ! { ! len = end - start; ! gfc_warning_now ("initialization string truncated to match variable " ! "at %L", &rvalue->where); ! } ! memcpy (&dest[start], rvalue->value.character.string, len); /* Pad with spaces. Substrings will already be blanked. */ if (len < end - start && ref == NULL) memset (&dest[start + len], ' ', end - (start + len)); + if (rvalue->ts.type == BT_HOLLERITH) + init->from_H = 1; + return init; } diff -Nrcpad gcc-4.1.1/gcc/fortran/decl.c gcc-4.1.2/gcc/fortran/decl.c *** gcc-4.1.1/gcc/fortran/decl.c Fri Feb 10 20:09:41 2006 --- gcc-4.1.2/gcc/fortran/decl.c Mon Nov 6 17:18:03 2006 *************** match_old_style_init (const char *name) *** 385,398 **** { match m; gfc_symtree *st; gfc_data *newdata; /* Set up data structure to hold initializers. */ gfc_find_sym_tree (name, NULL, 0, &st); ! newdata = gfc_get_data (); newdata->var = gfc_get_data_variable (); newdata->var->expr = gfc_get_variable_expr (st); /* Match initial value list. This also eats the terminal '/'. */ --- 385,401 ---- { match m; gfc_symtree *st; + gfc_symbol *sym; gfc_data *newdata; /* Set up data structure to hold initializers. */ gfc_find_sym_tree (name, NULL, 0, &st); ! sym = st->n.sym; ! newdata = gfc_get_data (); newdata->var = gfc_get_data_variable (); newdata->var->expr = gfc_get_variable_expr (st); + newdata->where = gfc_current_locus; /* Match initial value list. This also eats the terminal '/'. */ *************** match_old_style_init (const char *name) *** 410,415 **** --- 413,425 ---- return MATCH_ERROR; } + /* Mark the variable as having appeared in a data statement. */ + if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE) + { + gfc_free (newdata); + return MATCH_ERROR; + } + /* Chain in namespace list of DATA initializers. */ newdata->next = gfc_current_ns->data; gfc_current_ns->data = newdata; *************** end: *** 597,609 **** parent, then the symbol is just created in the current unit. */ static int ! get_proc_name (const char *name, gfc_symbol ** result) { gfc_symtree *st; gfc_symbol *sym; int rc; ! if (gfc_current_ns->parent == NULL) rc = gfc_get_symbol (name, NULL, result); else rc = gfc_get_symbol (name, gfc_current_ns->parent, result); --- 607,626 ---- parent, then the symbol is just created in the current unit. */ static int ! get_proc_name (const char *name, gfc_symbol ** result, ! bool module_fcn_entry) { gfc_symtree *st; gfc_symbol *sym; int rc; ! /* Module functions have to be left in their own namespace because ! they have potentially (almost certainly!) already been referenced. ! In this sense, they are rather like external functions. This is ! fixed up in resolve.c(resolve_entries), where the symbol name- ! space is set to point to the master function, so that the fake ! result mechanism can work. */ ! if (module_fcn_entry) rc = gfc_get_symbol (name, NULL, result); else rc = gfc_get_symbol (name, gfc_current_ns->parent, result); *************** get_proc_name (const char *name, gfc_sym *** 619,625 **** accessible names. */ if (sym->attr.flavor != 0 && sym->attr.proc != 0 ! && sym->formal) gfc_error_now ("Procedure '%s' at %C is already defined at %L", name, &sym->declared_at); --- 636,643 ---- accessible names. */ if (sym->attr.flavor != 0 && sym->attr.proc != 0 ! && (sym->attr.subroutine || sym->attr.function) ! && sym->attr.if_source != IFSRC_UNKNOWN) gfc_error_now ("Procedure '%s' at %C is already defined at %L", name, &sym->declared_at); *************** get_proc_name (const char *name, gfc_sym *** 627,635 **** signature for this is that ts.kind is set. Legitimate references only set ts.type. */ if (sym->ts.kind != 0 && sym->attr.proc == 0 && gfc_current_ns->parent != NULL ! && sym->attr.access == 0) gfc_error_now ("Procedure '%s' at %C has an explicit interface" " and must not have attributes declared at %L", name, &sym->declared_at); --- 645,655 ---- signature for this is that ts.kind is set. Legitimate references only set ts.type. */ if (sym->ts.kind != 0 + && !sym->attr.implicit_type && sym->attr.proc == 0 && gfc_current_ns->parent != NULL ! && sym->attr.access == 0 ! && !module_fcn_entry) gfc_error_now ("Procedure '%s' at %C has an explicit interface" " and must not have attributes declared at %L", name, &sym->declared_at); *************** get_proc_name (const char *name, gfc_sym *** 638,655 **** if (gfc_current_ns->parent == NULL || *result == NULL) return rc; ! st = gfc_new_symtree (&gfc_current_ns->sym_root, name); st->n.sym = sym; sym->refs++; /* See if the procedure should be a module procedure */ ! 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, ! sym->name, NULL) == FAILURE) rc = 2; return rc; --- 658,680 ---- if (gfc_current_ns->parent == NULL || *result == NULL) return rc; ! /* Module function entries will already have a symtree in ! the current namespace but will need one at module level. */ ! if (module_fcn_entry) ! st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name); ! else ! st = gfc_new_symtree (&gfc_current_ns->sym_root, name); st->n.sym = sym; sym->refs++; /* See if the procedure should be a module procedure */ ! if (((sym->ns->proc_name != NULL ! && sym->ns->proc_name->attr.flavor == FL_MODULE ! && sym->attr.proc != PROC_MODULE) || module_fcn_entry) ! && gfc_add_procedure (&sym->attr, PROC_MODULE, ! sym->name, NULL) == FAILURE) rc = 2; return rc; *************** gfc_set_constant_character_len (int len, *** 712,721 **** slen = expr->value.character.length; if (len != slen) { ! s = gfc_getmem (len); memcpy (s, expr->value.character.string, MIN (len, slen)); if (len > slen) memset (&s[slen], ' ', len - slen); gfc_free (expr->value.character.string); expr->value.character.string = s; expr->value.character.length = len; --- 737,747 ---- slen = expr->value.character.length; if (len != slen) { ! s = gfc_getmem (len + 1); memcpy (s, expr->value.character.string, MIN (len, slen)); if (len > slen) memset (&s[slen], ' ', len - slen); + s[len] = '\0'; gfc_free (expr->value.character.string); expr->value.character.string = s; expr->value.character.length = len; *************** add_init_expr_to_sym (const char *name, *** 855,864 **** sym->ts.cl->next = gfc_current_ns->cl_list; gfc_current_ns->cl_list = sym->ts.cl; ! if (init->expr_type == EXPR_CONSTANT) ! sym->ts.cl->length = ! gfc_int_expr (init->value.character.length); ! else if (init->expr_type == EXPR_ARRAY) sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length); } /* Update initializer character length according symbol. */ --- 881,888 ---- sym->ts.cl->next = gfc_current_ns->cl_list; gfc_current_ns->cl_list = sym->ts.cl; ! if (sym->attr.flavor == FL_PARAMETER ! && init->expr_type == EXPR_ARRAY) sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length); } /* Update initializer character length according symbol. */ *************** variable_decl (int elem) *** 1155,1160 **** --- 1179,1198 ---- goto cleanup; } + /* An interface body specifies all of the procedure's characteristics and these + shall be consistent with those specified in the procedure definition, except + that the interface may specify a procedure that is not pure if the procedure + is defined to be pure(12.3.2). */ + if (current_ts.type == BT_DERIVED + && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY + && current_ts.derived->ns != gfc_current_ns) + { + gfc_error ("the type of '%s' at %C has not been declared within the " + "interface", name); + m = MATCH_ERROR; + goto cleanup; + } + /* In functions that have a RESULT variable defined, the function name always refers to function calls. Therefore, the name is not allowed to appear in specification statements. */ *************** gfc_match_function_decl (void) *** 2566,2572 **** return MATCH_NO; } ! if (get_proc_name (name, &sym)) return MATCH_ERROR; gfc_new_block = sym; --- 2604,2610 ---- return MATCH_NO; } ! if (get_proc_name (name, &sym, false)) return MATCH_ERROR; gfc_new_block = sym; *************** gfc_match_function_decl (void) *** 2602,2608 **** || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE) goto cleanup; ! if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN) { gfc_error ("Function '%s' at %C already has a type of %s", name, gfc_basic_typename (sym->ts.type)); --- 2640,2648 ---- || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE) goto cleanup; ! if (current_ts.type != BT_UNKNOWN ! && sym->ts.type != BT_UNKNOWN ! && !sym->attr.implicit_type) { gfc_error ("Function '%s' at %C already has a type of %s", name, gfc_basic_typename (sym->ts.type)); *************** gfc_match_entry (void) *** 2664,2669 **** --- 2704,2710 ---- match m; gfc_entry_list *el; locus old_loc; + bool module_procedure; m = gfc_match_name (name); if (m != MATCH_YES) *************** gfc_match_entry (void) *** 2724,2739 **** return MATCH_ERROR; } if (gfc_current_ns->parent != NULL && gfc_current_ns->parent->proc_name ! && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE) { gfc_error("ENTRY statement at %C cannot appear in a " "contained procedure"); return MATCH_ERROR; } ! if (get_proc_name (name, &entry)) return MATCH_ERROR; proc = gfc_current_block (); --- 2765,2790 ---- return MATCH_ERROR; } + module_procedure = gfc_current_ns->parent != NULL + && gfc_current_ns->parent->proc_name + && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE; + if (gfc_current_ns->parent != NULL && gfc_current_ns->parent->proc_name ! && !module_procedure) { gfc_error("ENTRY statement at %C cannot appear in a " "contained procedure"); return MATCH_ERROR; } ! /* Module function entries need special care in get_proc_name ! because previous references within the function will have ! created symbols attached to the current namespace. */ ! if (get_proc_name (name, &entry, ! gfc_current_ns->parent != NULL ! && module_procedure ! && gfc_current_ns->proc_name->attr.function)) return MATCH_ERROR; proc = gfc_current_block (); *************** gfc_match_subroutine (void) *** 2862,2868 **** if (m != MATCH_YES) return m; ! if (get_proc_name (name, &sym)) return MATCH_ERROR; gfc_new_block = sym; --- 2913,2919 ---- if (m != MATCH_YES) return m; ! if (get_proc_name (name, &sym, false)) return MATCH_ERROR; gfc_new_block = sym; diff -Nrcpad gcc-4.1.1/gcc/fortran/dump-parse-tree.c gcc-4.1.2/gcc/fortran/dump-parse-tree.c *** gcc-4.1.1/gcc/fortran/dump-parse-tree.c Tue Mar 7 00:06:37 2006 --- gcc-4.1.2/gcc/fortran/dump-parse-tree.c Fri Nov 10 21:52:00 2006 *************** gfc_show_expr (gfc_expr * p) *** 348,353 **** --- 348,363 ---- break; case EXPR_CONSTANT: + if (p->from_H || p->ts.type == BT_HOLLERITH) + { + gfc_status ("%dH", p->value.character.length); + c = p->value.character.string; + for (i = 0; i < p->value.character.length; i++, c++) + { + gfc_status_char (*c); + } + break; + } switch (p->ts.type) { case BT_INTEGER: *************** gfc_show_code_node (int level, gfc_code *** 818,823 **** --- 828,834 ---- gfc_status ("ENTRY %s", c->ext.entry->sym->name); break; + case EXEC_INIT_ASSIGN: case EXEC_ASSIGN: gfc_status ("ASSIGN "); gfc_show_expr (c->expr); *************** gfc_show_code_node (int level, gfc_code *** 862,868 **** break; case EXEC_CALL: ! gfc_status ("CALL %s ", c->resolved_sym->name); gfc_show_actual_arglist (c->ext.actual); break; --- 873,885 ---- break; case EXEC_CALL: ! if (c->resolved_sym) ! gfc_status ("CALL %s ", c->resolved_sym->name); ! else if (c->symtree) ! gfc_status ("CALL %s ", c->symtree->name); ! else ! gfc_status ("CALL ?? "); ! gfc_show_actual_arglist (c->ext.actual); break; diff -Nrcpad gcc-4.1.1/gcc/fortran/expr.c gcc-4.1.2/gcc/fortran/expr.c *** gcc-4.1.1/gcc/fortran/expr.c Sun Apr 23 05:33:16 2006 --- gcc-4.1.2/gcc/fortran/expr.c Wed Dec 13 22:37:21 2006 *************** simplify_intrinsic_op (gfc_expr * p, int *** 869,874 **** --- 869,876 ---- return FAILURE; } + result->rank = p->rank; + result->where = p->where; gfc_replace_expr (p, result); return SUCCESS; *************** simplify_constructor (gfc_constructor * *** 900,949 **** /* Pull a single array element out of an array constructor. */ ! static gfc_constructor * ! find_array_element (gfc_constructor * cons, gfc_array_ref * ar) { unsigned long nelemen; int i; mpz_t delta; mpz_t offset; mpz_init_set_ui (offset, 0); mpz_init (delta); for (i = 0; i < ar->dimen; i++) { ! if (ar->start[i]->expr_type != EXPR_CONSTANT) { cons = NULL; ! break; } ! mpz_sub (delta, ar->start[i]->value.integer, ar->as->lower[i]->value.integer); mpz_add (offset, offset, delta); } if (cons) { ! if (mpz_fits_ulong_p (offset)) { ! for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) { ! if (cons->iterator) ! { ! cons = NULL; ! break; ! } ! cons = cons->next; } } - else - cons = NULL; } mpz_clear (delta); mpz_clear (offset); ! ! return cons; } --- 902,971 ---- /* Pull a single array element out of an array constructor. */ ! static try ! find_array_element (gfc_constructor * cons, gfc_array_ref * ar, ! gfc_constructor ** rval) { unsigned long nelemen; int i; mpz_t delta; mpz_t offset; + gfc_expr *e; + try t; + + t = SUCCESS; + e = NULL; mpz_init_set_ui (offset, 0); mpz_init (delta); for (i = 0; i < ar->dimen; i++) { ! e = gfc_copy_expr (ar->start[i]); ! if (e->expr_type != EXPR_CONSTANT) { cons = NULL; ! goto depart; } ! ! /* Check the bounds. */ ! if (ar->as->upper[i] ! && (mpz_cmp (e->value.integer, ! ar->as->upper[i]->value.integer) > 0 ! || mpz_cmp (e->value.integer, ! ar->as->lower[i]->value.integer) < 0)) ! { ! gfc_error ("index in dimension %d is out of bounds " ! "at %L", i + 1, &ar->c_where[i]); ! cons = NULL; ! t = FAILURE; ! goto depart; ! } ! ! mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); mpz_add (offset, offset, delta); } if (cons) { ! for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) { ! if (cons->iterator) { ! cons = NULL; ! goto depart; } + cons = cons->next; } } + depart: mpz_clear (delta); mpz_clear (offset); ! if (e) ! gfc_free_expr (e); ! *rval = cons; ! return t; } *************** remove_subobject_ref (gfc_expr * p, gfc_ *** 983,988 **** --- 1005,1288 ---- } + /* Pull an array section out of an array constructor. */ + + static try + find_array_section (gfc_expr *expr, gfc_ref *ref) + { + int idx; + int rank; + int d; + int shape_i; + long unsigned one = 1; + bool incr_ctr; + mpz_t start[GFC_MAX_DIMENSIONS]; + mpz_t end[GFC_MAX_DIMENSIONS]; + mpz_t stride[GFC_MAX_DIMENSIONS]; + mpz_t delta[GFC_MAX_DIMENSIONS]; + mpz_t ctr[GFC_MAX_DIMENSIONS]; + mpz_t delta_mpz; + mpz_t tmp_mpz; + mpz_t nelts; + mpz_t ptr; + mpz_t index; + gfc_constructor *cons; + gfc_constructor *base; + gfc_expr *begin; + gfc_expr *finish; + gfc_expr *step; + gfc_expr *upper; + gfc_expr *lower; + gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c; + try t; + + t = SUCCESS; + + base = expr->value.constructor; + expr->value.constructor = NULL; + + rank = ref->u.ar.as->rank; + + if (expr->shape == NULL) + expr->shape = gfc_get_shape (rank); + + mpz_init_set_ui (delta_mpz, one); + mpz_init_set_ui (nelts, one); + mpz_init (tmp_mpz); + + /* Do the initialization now, so that we can cleanup without + keeping track of where we were. */ + for (d = 0; d < rank; d++) + { + mpz_init (delta[d]); + mpz_init (start[d]); + mpz_init (end[d]); + mpz_init (ctr[d]); + mpz_init (stride[d]); + vecsub[d] = NULL; + } + + /* Build the counters to clock through the array reference. */ + shape_i = 0; + for (d = 0; d < rank; d++) + { + /* Make this stretch of code easier on the eye! */ + begin = ref->u.ar.start[d]; + finish = ref->u.ar.end[d]; + step = ref->u.ar.stride[d]; + lower = ref->u.ar.as->lower[d]; + upper = ref->u.ar.as->upper[d]; + + if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ + { + gcc_assert(begin); + gcc_assert(begin->expr_type == EXPR_ARRAY); + gcc_assert(begin->rank == 1); + gcc_assert(begin->shape); + + vecsub[d] = begin->value.constructor; + mpz_set (ctr[d], vecsub[d]->expr->value.integer); + mpz_mul (nelts, nelts, begin->shape[0]); + mpz_set (expr->shape[shape_i++], begin->shape[0]); + + /* Check bounds. */ + for (c = vecsub[d]; c; c = c->next) + { + if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0 + || mpz_cmp (c->expr->value.integer, lower->value.integer) < 0) + { + gfc_error ("index in dimension %d is out of bounds " + "at %L", d + 1, &ref->u.ar.c_where[d]); + t = FAILURE; + goto cleanup; + } + } + } + else + { + if ((begin && begin->expr_type != EXPR_CONSTANT) + || (finish && finish->expr_type != EXPR_CONSTANT) + || (step && step->expr_type != EXPR_CONSTANT)) + { + t = FAILURE; + goto cleanup; + } + + /* Obtain the stride. */ + if (step) + mpz_set (stride[d], step->value.integer); + else + mpz_set_ui (stride[d], one); + + if (mpz_cmp_ui (stride[d], 0) == 0) + mpz_set_ui (stride[d], one); + + /* Obtain the start value for the index. */ + if (begin) + mpz_set (start[d], begin->value.integer); + else + mpz_set (start[d], lower->value.integer); + + mpz_set (ctr[d], start[d]); + + /* Obtain the end value for the index. */ + if (finish) + mpz_set (end[d], finish->value.integer); + else + mpz_set (end[d], upper->value.integer); + + /* Separate 'if' because elements sometimes arrive with + non-null end. */ + if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) + mpz_set (end [d], begin->value.integer); + + /* Check the bounds. */ + if (mpz_cmp (ctr[d], upper->value.integer) > 0 + || mpz_cmp (end[d], upper->value.integer) > 0 + || mpz_cmp (ctr[d], lower->value.integer) < 0 + || mpz_cmp (end[d], lower->value.integer) < 0) + { + gfc_error ("index in dimension %d is out of bounds " + "at %L", d + 1, &ref->u.ar.c_where[d]); + t = FAILURE; + goto cleanup; + } + + /* Calculate the number of elements and the shape. */ + mpz_abs (tmp_mpz, stride[d]); + mpz_div (tmp_mpz, stride[d], tmp_mpz); + mpz_add (tmp_mpz, end[d], tmp_mpz); + mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); + mpz_div (tmp_mpz, tmp_mpz, stride[d]); + mpz_mul (nelts, nelts, tmp_mpz); + + /* An element reference reduces the rank of the expression; don't add + anything to the shape array. */ + if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) + mpz_set (expr->shape[shape_i++], tmp_mpz); + } + + /* Calculate the 'stride' (=delta) for conversion of the + counter values into the index along the constructor. */ + mpz_set (delta[d], delta_mpz); + mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); + mpz_add_ui (tmp_mpz, tmp_mpz, one); + mpz_mul (delta_mpz, delta_mpz, tmp_mpz); + } + + mpz_init (index); + mpz_init (ptr); + cons = base; + + /* Now clock through the array reference, calculating the index in + the source constructor and transferring the elements to the new + constructor. */ + for (idx = 0; idx < (int)mpz_get_si (nelts); idx++) + { + if (ref->u.ar.offset) + mpz_set (ptr, ref->u.ar.offset->value.integer); + else + mpz_init_set_ui (ptr, 0); + + incr_ctr = true; + for (d = 0; d < rank; d++) + { + mpz_set (tmp_mpz, ctr[d]); + mpz_sub_ui (tmp_mpz, tmp_mpz, one); + mpz_mul (tmp_mpz, tmp_mpz, delta[d]); + mpz_add (ptr, ptr, tmp_mpz); + + if (!incr_ctr) continue; + + if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ + { + gcc_assert(vecsub[d]); + + if (!vecsub[d]->next) + vecsub[d] = ref->u.ar.start[d]->value.constructor; + else + { + vecsub[d] = vecsub[d]->next; + incr_ctr = false; + } + mpz_set (ctr[d], vecsub[d]->expr->value.integer); + } + else + { + mpz_add (ctr[d], ctr[d], stride[d]); + + if (mpz_cmp_ui (stride[d], 0) > 0 ? + mpz_cmp (ctr[d], end[d]) > 0 : + mpz_cmp (ctr[d], end[d]) < 0) + mpz_set (ctr[d], start[d]); + else + incr_ctr = false; + } + } + + /* There must be a better way of dealing with negative strides + than resetting the index and the constructor pointer! */ + if (mpz_cmp (ptr, index) < 0) + { + mpz_set_ui (index, 0); + cons = base; + } + + while (mpz_cmp (ptr, index) > 0) + { + mpz_add_ui (index, index, one); + cons = cons->next; + } + + gfc_append_constructor (expr, gfc_copy_expr (cons->expr)); + } + + mpz_clear (ptr); + mpz_clear (index); + + cleanup: + + mpz_clear (delta_mpz); + mpz_clear (tmp_mpz); + mpz_clear (nelts); + for (d = 0; d < rank; d++) + { + mpz_clear (delta[d]); + mpz_clear (start[d]); + mpz_clear (end[d]); + mpz_clear (ctr[d]); + mpz_clear (stride[d]); + } + gfc_free_constructor (base); + return t; + } + + /* Pull a substring out of an expression. */ + + static try + find_substring_ref (gfc_expr *p, gfc_expr **newp) + { + int end; + int start; + char *chr; + + if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT + || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) + return FAILURE; + + *newp = gfc_copy_expr (p); + chr = p->value.character.string; + end = (int)mpz_get_ui (p->ref->u.ss.end->value.integer); + start = (int)mpz_get_ui (p->ref->u.ss.start->value.integer); + + (*newp)->value.character.length = end - start + 1; + strncpy ((*newp)->value.character.string, &chr[start - 1], + (*newp)->value.character.length); + return SUCCESS; + } + + + /* Simplify a subobject reference of a constructor. This occurs when parameter variable values are substituted. */ *************** static try *** 990,995 **** --- 1290,1296 ---- simplify_const_ref (gfc_expr * p) { gfc_constructor *cons; + gfc_expr *newp; while (p->ref) { *************** simplify_const_ref (gfc_expr * p) *** 999,1022 **** switch (p->ref->u.ar.type) { case AR_ELEMENT: ! cons = find_array_element (p->value.constructor, &p->ref->u.ar); if (!cons) return SUCCESS; remove_subobject_ref (p, cons); break; case AR_FULL: ! if (p->ref->next != NULL) { ! /* TODO: Simplify array subobject references. */ ! return SUCCESS; } ! gfc_free_ref_list (p->ref); ! p->ref = NULL; break; default: - /* TODO: Simplify array subsections. */ return SUCCESS; } --- 1300,1339 ---- switch (p->ref->u.ar.type) { case AR_ELEMENT: ! if (find_array_element (p->value.constructor, ! &p->ref->u.ar, ! &cons) == FAILURE) ! return FAILURE; ! if (!cons) return SUCCESS; + remove_subobject_ref (p, cons); break; + case AR_SECTION: + if (find_array_section (p, p->ref) == FAILURE) + return FAILURE; + p->ref->u.ar.type = AR_FULL; + + /* FALLTHROUGH */ + case AR_FULL: ! if (p->ref->next != NULL ! && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED)) { ! cons = p->value.constructor; ! for (; cons; cons = cons->next) ! { ! cons->expr->ref = copy_ref (p->ref->next); ! simplify_const_ref (cons->expr); ! } } ! gfc_free_ref_list (p->ref); ! p->ref = NULL; break; default: return SUCCESS; } *************** simplify_const_ref (gfc_expr * p) *** 1028,1035 **** break; case REF_SUBSTRING: ! /* TODO: Constant substrings. */ ! return SUCCESS; } } --- 1345,1357 ---- break; case REF_SUBSTRING: ! if (find_substring_ref (p, &newp) == FAILURE) ! return FAILURE; ! ! gfc_replace_expr (p, newp); ! gfc_free_ref_list (p->ref); ! p->ref = NULL; ! break; } } *************** simplify_ref_chain (gfc_ref * ref, int t *** 1060,1065 **** --- 1382,1388 ---- if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE) return FAILURE; + } break; *************** simplify_parameter_variable (gfc_expr * *** 1086,1091 **** --- 1409,1419 ---- try t; e = gfc_copy_expr (p->symtree->n.sym->value); + if (e == NULL) + return FAILURE; + + e->rank = p->rank; + /* Do not copy subobject refs for constant. */ if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) e->ref = copy_ref (p->ref); *************** gfc_simplify_expr (gfc_expr * p, int typ *** 1157,1165 **** gfc_extract_int (p->ref->u.ss.start, &start); start--; /* Convert from one-based to zero-based. */ gfc_extract_int (p->ref->u.ss.end, &end); ! s = gfc_getmem (end - start + 1); memcpy (s, p->value.character.string + start, end - start); ! s[end] = '\0'; /* TODO: C-style string for debugging. */ gfc_free (p->value.character.string); p->value.character.string = s; p->value.character.length = end - start; --- 1485,1493 ---- gfc_extract_int (p->ref->u.ss.start, &start); start--; /* Convert from one-based to zero-based. */ gfc_extract_int (p->ref->u.ss.end, &end); ! s = gfc_getmem (end - start + 2); memcpy (s, p->value.character.string + start, end - start); ! s[end-start+1] = '\0'; /* TODO: C-style string for debugging. */ gfc_free (p->value.character.string); p->value.character.string = s; p->value.character.length = end - start; *************** gfc_simplify_expr (gfc_expr * p, int typ *** 1209,1215 **** if (simplify_constructor (p->value.constructor, type) == FAILURE) return FAILURE; ! if (p->expr_type == EXPR_ARRAY) gfc_expand_constructor (p); if (simplify_const_ref (p) == FAILURE) --- 1537,1545 ---- if (simplify_constructor (p->value.constructor, type) == FAILURE) return FAILURE; ! if (p->expr_type == EXPR_ARRAY ! && p->ref && p->ref->type == REF_ARRAY ! && p->ref->u.ar.type == AR_FULL) gfc_expand_constructor (p); if (simplify_const_ref (p) == FAILURE) diff -Nrcpad gcc-4.1.1/gcc/fortran/f95-lang.c gcc-4.1.2/gcc/fortran/f95-lang.c *** gcc-4.1.1/gcc/fortran/f95-lang.c Mon Mar 27 13:15:48 2006 --- gcc-4.1.2/gcc/fortran/f95-lang.c Fri Nov 10 21:52:00 2006 *************** gfc_init_builtin_functions (void) *** 870,875 **** --- 870,882 ---- BUILT_IN_COPYSIGN, "copysign", true); gfc_define_builtin ("__builtin_copysignf", mfunc_float[1], BUILT_IN_COPYSIGNF, "copysignf", true); + + gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1], + BUILT_IN_FMODL, "fmodl", true); + gfc_define_builtin ("__builtin_fmod", mfunc_double[1], + BUILT_IN_FMOD, "fmod", true); + gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], + BUILT_IN_FMODF, "fmodf", true); /* These are used to implement the ** operator. */ gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1], diff -Nrcpad gcc-4.1.1/gcc/fortran/gfortran.h gcc-4.1.2/gcc/fortran/gfortran.h *** gcc-4.1.1/gcc/fortran/gfortran.h Fri Apr 7 21:07:52 2006 --- gcc-4.1.2/gcc/fortran/gfortran.h Fri Nov 10 21:52:00 2006 *************** typedef struct gfc_symbol *** 772,777 **** --- 772,779 ---- order. */ int dummy_order; + int entry_id; + gfc_namelist *namelist, *namelist_tail; /* Change management fields. Symbols that might be modified by the *************** gfc_forall_iterator; *** 1417,1424 **** typedef enum { EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, ! EXEC_GOTO, EXEC_CALL, EXEC_RETURN, EXEC_ENTRY, ! EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_ALLOCATE, EXEC_DEALLOCATE, --- 1419,1426 ---- typedef enum { EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, ! EXEC_GOTO, EXEC_CALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY, ! EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN, EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_ALLOCATE, EXEC_DEALLOCATE, *************** typedef struct *** 1543,1548 **** --- 1545,1551 ---- int flag_max_stack_var_size; int flag_module_access_private; int flag_no_backend; + int flag_range_check; int flag_pack_derived; int flag_repack_arrays; int flag_preprocessed; *************** void gfc_free_equiv (gfc_equiv *); *** 1857,1862 **** --- 1860,1868 ---- void gfc_free_data (gfc_data *); void gfc_free_case_list (gfc_case *); + /* matchexp.c -- FIXME too? */ + gfc_expr *gfc_get_parentheses (gfc_expr *); + /* expr.c */ void gfc_free_actual_arglist (gfc_actual_arglist *); gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); *************** void gfc_simplify_iterator_var (gfc_expr *** 1930,1935 **** --- 1936,1942 ---- try gfc_expand_constructor (gfc_expr *); int gfc_constant_ac (gfc_expr *); int gfc_expanded_ac (gfc_expr *); + void gfc_resolve_character_array_constructor (gfc_expr *); try gfc_resolve_array_constructor (gfc_expr *); try gfc_check_constructor_type (gfc_expr *); try gfc_check_iter_variable (gfc_expr *); diff -Nrcpad gcc-4.1.1/gcc/fortran/interface.c gcc-4.1.2/gcc/fortran/interface.c *** gcc-4.1.1/gcc/fortran/interface.c Sun Mar 19 12:45:42 2006 --- gcc-4.1.2/gcc/fortran/interface.c Wed Aug 30 05:19:34 2006 *************** gfc_match_interface (void) *** 217,222 **** --- 217,229 ---- && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; + if (sym->attr.dummy) + { + gfc_error ("Dummy procedure '%s' at %C cannot have a " + "generic interface", sym->name); + return MATCH_ERROR; + } + current_interface.sym = gfc_new_block = sym; break; *************** check_operator_interface (gfc_interface *** 496,502 **** for (formal = intr->sym->formal; formal; formal = formal->next) { sym = formal->sym; ! if (args == 0) { t1 = sym->ts.type; --- 503,514 ---- for (formal = intr->sym->formal; formal; formal = formal->next) { sym = formal->sym; ! if (sym == NULL) ! { ! gfc_error ("Alternate return cannot appear in operator " ! "interface at %L", &intr->where); ! return; ! } if (args == 0) { t1 = sym->ts.type; *************** check_operator_interface (gfc_interface *** 524,529 **** --- 536,559 ---- &intr->where); return; } + if (args != 2) + { + gfc_error + ("Assignment operator interface at %L must have two arguments", + &intr->where); + return; + } + if (sym->formal->sym->ts.type != BT_DERIVED + && sym->formal->next->sym->ts.type != BT_DERIVED + && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type + || (gfc_numeric_ts (&sym->formal->sym->ts) + && gfc_numeric_ts (&sym->formal->next->sym->ts)))) + { + gfc_error + ("Assignment operator interface at %L must not redefine " + "an INTRINSIC type assignment", &intr->where); + return; + } } else { *************** compare_parameter (gfc_symbol * formal, *** 1103,1109 **** && !compare_type_rank (formal, actual->symtree->n.sym)) return 0; ! if (formal->attr.if_source == IFSRC_UNKNOWN) return 1; /* Assume match */ return compare_interfaces (formal, actual->symtree->n.sym, 0); --- 1133,1140 ---- && !compare_type_rank (formal, actual->symtree->n.sym)) return 0; ! if (formal->attr.if_source == IFSRC_UNKNOWN ! || actual->symtree->n.sym->attr.external) return 1; /* Assume match */ return compare_interfaces (formal, actual->symtree->n.sym, 0); *************** compare_actual_formal (gfc_actual_arglis *** 1157,1162 **** --- 1188,1194 ---- { gfc_actual_arglist **new, *a, *actual, temp; gfc_formal_arglist *f; + gfc_gsymbol *gsym; int i, n, na; bool rank_check; *************** compare_actual_formal (gfc_actual_arglis *** 1256,1261 **** --- 1288,1322 ---- return 0; } + /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is + provided for a procedure formal argument. */ + if (a->expr->ts.type != BT_PROCEDURE + && a->expr->expr_type == EXPR_VARIABLE + && f->sym->attr.flavor == FL_PROCEDURE) + { + gsym = gfc_find_gsymbol (gfc_gsym_root, + a->expr->symtree->n.sym->name); + if (gsym == NULL || (gsym->type != GSYM_FUNCTION + && gsym->type != GSYM_SUBROUTINE)) + { + if (where) + gfc_error ("Expected a procedure for argument '%s' at %L", + f->sym->name, &a->expr->where); + return 0; + } + } + + if (f->sym->attr.flavor == FL_PROCEDURE + && f->sym->attr.pure + && a->expr->ts.type == BT_PROCEDURE + && !a->expr->symtree->n.sym->attr.pure) + { + if (where) + gfc_error ("Expected a PURE procedure for argument '%s' at %L", + f->sym->name, &a->expr->where); + return 0; + } + if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE && a->expr->expr_type == EXPR_VARIABLE *************** gfc_extend_assign (gfc_code * c, gfc_nam *** 1798,1804 **** } /* Replace the assignment with the call. */ ! c->op = EXEC_CALL; c->symtree = find_sym_in_symtree (sym); c->expr = NULL; c->expr2 = NULL; --- 1859,1865 ---- } /* Replace the assignment with the call. */ ! c->op = EXEC_ASSIGN_CALL; c->symtree = find_sym_in_symtree (sym); c->expr = NULL; c->expr2 = NULL; diff -Nrcpad gcc-4.1.1/gcc/fortran/intrinsic.c gcc-4.1.2/gcc/fortran/intrinsic.c *** gcc-4.1.1/gcc/fortran/intrinsic.c Sun Apr 23 05:33:16 2006 --- gcc-4.1.2/gcc/fortran/intrinsic.c Wed Jul 26 09:44:59 2006 *************** add_functions (void) *** 1806,1812 **** make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77); ! add_sym_2 ("modulo", 1, 1, BT_REAL, di, GFC_STD_F95, gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo, a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED); --- 1806,1812 ---- make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77); ! add_sym_2 ("modulo", 1, 0, BT_REAL, di, GFC_STD_F95, gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo, a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED); *************** add_functions (void) *** 2136,2142 **** make_generic ("tiny", GFC_ISYM_NONE, GFC_STD_F95); add_sym_3 ("transfer", 0, 1, BT_REAL, dr, GFC_STD_F95, ! gfc_check_transfer, NULL, gfc_resolve_transfer, src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED, sz, BT_INTEGER, di, OPTIONAL); --- 2136,2142 ---- make_generic ("tiny", GFC_ISYM_NONE, GFC_STD_F95); add_sym_3 ("transfer", 0, 1, BT_REAL, dr, GFC_STD_F95, ! gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer, src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED, sz, BT_INTEGER, di, OPTIONAL); *************** add_subroutines (void) *** 2237,2244 **** /* More G77 compatibility garbage. */ add_sym_2s ("ctime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, ! gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub, ! tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED); add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub, --- 2237,2252 ---- /* More G77 compatibility garbage. */ add_sym_2s ("ctime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, ! gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub, ! tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED); ! ! add_sym_1s ("idate", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, ! gfc_check_itime_idate, NULL, gfc_resolve_idate, ! vl, BT_INTEGER, 4, REQUIRED); ! ! add_sym_1s ("itime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, ! gfc_check_itime_idate, NULL, gfc_resolve_itime, ! vl, BT_INTEGER, 4, REQUIRED); add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub, diff -Nrcpad gcc-4.1.1/gcc/fortran/intrinsic.h gcc-4.1.2/gcc/fortran/intrinsic.h *** gcc-4.1.1/gcc/fortran/intrinsic.h Sun Nov 13 09:33:19 2005 --- gcc-4.1.2/gcc/fortran/intrinsic.h Wed Jul 26 09:44:59 2006 *************** try gfc_check_fgetput_sub (gfc_expr *, g *** 159,164 **** --- 159,165 ---- try gfc_check_ftell_sub (gfc_expr *, gfc_expr *); try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *); try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *); + try gfc_check_itime_idate (gfc_expr *); try gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_perror (gfc_expr *); try gfc_check_rename_sub (gfc_expr *, gfc_expr *, gfc_expr *); *************** gfc_expr *gfc_simplify_sqrt (gfc_expr *) *** 276,281 **** --- 277,283 ---- gfc_expr *gfc_simplify_tan (gfc_expr *); gfc_expr *gfc_simplify_tanh (gfc_expr *); gfc_expr *gfc_simplify_tiny (gfc_expr *); + gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_trim (gfc_expr *); gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *); *************** void gfc_resolve_get_command (gfc_code * *** 444,449 **** --- 446,453 ---- void gfc_resolve_get_command_argument (gfc_code *); void gfc_resolve_get_environment_variable (gfc_code *); void gfc_resolve_hostnm_sub (gfc_code *); + void gfc_resolve_idate (gfc_code *); + void gfc_resolve_itime (gfc_code *); void gfc_resolve_kill_sub (gfc_code *); void gfc_resolve_mvbits (gfc_code *); void gfc_resolve_perror (gfc_code *); diff -Nrcpad gcc-4.1.1/gcc/fortran/intrinsic.texi gcc-4.1.2/gcc/fortran/intrinsic.texi *** gcc-4.1.1/gcc/fortran/intrinsic.texi Tue Mar 28 22:18:19 2006 --- gcc-4.1.2/gcc/fortran/intrinsic.texi Wed Jul 26 09:44:59 2006 *************** and editing. All contributions and corr *** 59,65 **** * @code{BIT_SIZE}: BIT_SIZE, Bit size inquiry function * @code{BTEST}: BTEST, Bit test function * @code{CEILING}: CEILING, Integer ceiling function ! * @code{CHAR}: CHAR, Character conversion function * @code{CMPLX}: CMPLX, Complex conversion function * @code{COMMAND_ARGUMENT_COUNT}: COMMAND_ARGUMENT_COUNT, Command line argument count * @code{CONJG}: CONJG, Complex conjugate function --- 59,65 ---- * @code{BIT_SIZE}: BIT_SIZE, Bit size inquiry function * @code{BTEST}: BTEST, Bit test function * @code{CEILING}: CEILING, Integer ceiling function ! * @code{CHAR}: CHAR, Integer-to-character conversion function * @code{CMPLX}: CMPLX, Complex conversion function * @code{COMMAND_ARGUMENT_COUNT}: COMMAND_ARGUMENT_COUNT, Command line argument count * @code{CONJG}: CONJG, Complex conjugate function *************** and editing. All contributions and corr *** 90,109 **** --- 90,140 ---- * @code{FDATE}: FDATE, Subroutine (or function) to get the current time as a string * @code{FLOAT}: FLOAT, Convert integer to default real * @code{FLOOR}: FLOOR, Integer floor function + * @code{FLUSH}: FLUSH, Flush I/O unit(s) * @code{FNUM}: FNUM, File number function + * @code{FRACTION}: FRACTION, Fractional part of the model representation * @code{FREE}: FREE, Memory de-allocation subroutine + * @code{GETGID}: GETGID, Group ID function + * @code{GETPID}: GETPID, Process ID function + * @code{GETUID}: GETUID, User ID function + * @code{HUGE}: HUGE, Largest number of a kind + * @code{IACHAR}: IACHAR, Code in @acronym{ASCII} collating sequence + * @code{ICHAR}: ICHAR, Character-to-integer conversion function + * @code{IDATE}: IDATE, Current local time (day/month/year) + * @code{IRAND}: IRAND, Integer pseudo-random number + * @code{ITIME}: ITIME, Current local time (hour/minutes/seconds) + * @code{KIND}: KIND, Kind of an entity * @code{LOC}: LOC, Returns the address of a variable * @code{LOG}: LOG, Logarithm function * @code{LOG10}: LOG10, Base 10 logarithm function * @code{MALLOC}: MALLOC, Dynamic memory allocation function + * @code{MAXEXPONENT}: MAXEXPONENT, Maximum exponent of a real kind + * @code{MINEXPONENT}: MINEXPONENT, Minimum exponent of a real kind + * @code{MOD}: MOD, Remainder function + * @code{MODULO}: MODULO, Modulo function + * @code{NEAREST}: NEAREST, Nearest representable number + * @code{NINT}: NINT, Nearest whole number + * @code{PRECISION}: PRECISION, Decimal precision of a real kind + * @code{RADIX}: RADIX, Base of a data model + * @code{RAND}: RAND, Real pseudo-random number + * @code{RANGE}: RANGE, Decimal exponent range of a real kind * @code{REAL}: REAL, Convert to real type + * @code{RRSPACING}: RRSPACING, Reciprocal of the relative spacing + * @code{SCALE}: SCALE, Scale a real value * @code{SECNDS}: SECNDS, Time function + * @code{SELECTED_INT_KIND}: SELECTED_INT_KIND, Choose integer kind + * @code{SELECTED_REAL_KIND}: SELECTED_REAL_KIND, Choose real kind + * @code{SET_EXPONENT}: SET_EXPONENT, Set the exponent of the model + * @code{SIGN}: SIGN, Sign copying function * @code{SIGNAL}: SIGNAL, Signal handling subroutine (or function) * @code{SIN}: SIN, Sine function * @code{SINH}: SINH, Hyperbolic sine function + * @code{SNGL}: SNGL, Convert double precision real to default real * @code{SQRT}: SQRT, Square-root function + * @code{SRAND}: SRAND, Reinitialize the random number generator * @code{TAN}: TAN, Tangent function * @code{TANH}: TANH, Hyperbolic tangent function + * @code{TINY}: TINY, Smallest positive number of a real kind @end menu @node Introduction *************** end program test_allocated *** 678,684 **** @node ANINT ! @section @code{ANINT} --- Imaginary part of complex number @findex @code{ANINT} intrinsic @findex @code{DNINT} intrinsic @cindex whole number --- 709,715 ---- @node ANINT ! @section @code{ANINT} --- Nearest whole number @findex @code{ANINT} intrinsic @findex @code{DNINT} intrinsic @cindex whole number *************** end program test_exponent *** 2755,2796 **** @end table - @node FREE - @section @code{FREE} --- Frees memory - @findex @code{FREE} intrinsic - @cindex FREE - - @table @asis - @item @emph{Description}: - Frees memory previously allocated by @code{MALLOC()}. The @code{FREE} - intrinsic is an extension intended to be used with Cray pointers, and is - provided in @command{gfortran} to allow user to compile legacy code. For - new code using Fortran 95 pointers, the memory de-allocation intrinsic is - @code{DEALLOCATE}. - - @item @emph{Option}: - gnu - - @item @emph{Class}: - subroutine - - @item @emph{Syntax}: - @code{FREE(PTR)} - - @item @emph{Arguments}: - @multitable @columnfractions .15 .80 - @item @var{PTR} @tab The type shall be @code{INTEGER}. It represents the - location of the memory that should be de-allocated. - @end multitable - - @item @emph{Return value}: - None - - @item @emph{Example}: - See @code{MALLOC} for an example. - @end table - - @node FDATE @section @code{FDATE} --- Get the current time as a string @findex @code{FDATE} intrinsic --- 2786,2791 ---- *************** end program test_floor *** 2919,2924 **** --- 2914,2951 ---- + @node FLUSH + @section @code{FLUSH} --- Flush I/O unit(s) + @findex @code{FLUSH} + @cindex flush + + @table @asis + @item @emph{Description}: + Flushes Fortran unit(s) currently open for output. Without the optional + argument, all units are flushed, otherwise just the unit specified. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + non-elemental subroutine + + @item @emph{Syntax}: + @code{CALL FLUSH(UNIT)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{UNIT} @tab (Optional) The type shall be @code{INTEGER}. + @end multitable + + @item @emph{Note}: + Beginning with the Fortran 2003 standard, there is a @code{FLUSH} + statement that should be prefered over the @code{FLUSH} intrinsic. + + @end table + + + @node FNUM @section @code{FNUM} --- File number function @findex @code{FNUM} intrinsic *************** end program test_fnum *** 2958,2963 **** --- 2985,3472 ---- @end smallexample @end table + + + @node FRACTION + @section @code{FRACTION} --- Fractional part of the model representation + @findex @code{FRACTION} intrinsic + @cindex fractional part + + @table @asis + @item @emph{Description}: + @code{FRACTION(X)} returns the fractional part of the model + representation of @code{X}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{Y = FRACTION(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type of the argument shall be a @code{REAL}. + @end multitable + + @item @emph{Return value}: + The return value is of the same type and kind as the argument. + The fractional part of the model representation of @code{X} is returned; + it is @code{X * RADIX(X)**(-EXPONENT(X))}. + + @item @emph{Example}: + @smallexample + program test_fraction + real :: x + x = 178.1387e-4 + print *, fraction(x), x * radix(x)**(-exponent(x)) + end program test_fraction + @end smallexample + + @end table + + + + @node FREE + @section @code{FREE} --- Frees memory + @findex @code{FREE} intrinsic + @cindex FREE + + @table @asis + @item @emph{Description}: + Frees memory previously allocated by @code{MALLOC()}. The @code{FREE} + intrinsic is an extension intended to be used with Cray pointers, and is + provided in @command{gfortran} to allow user to compile legacy code. For + new code using Fortran 95 pointers, the memory de-allocation intrinsic is + @code{DEALLOCATE}. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + subroutine + + @item @emph{Syntax}: + @code{FREE(PTR)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{PTR} @tab The type shall be @code{INTEGER}. It represents the + location of the memory that should be de-allocated. + @end multitable + + @item @emph{Return value}: + None + + @item @emph{Example}: + See @code{MALLOC} for an example. + @end table + + + + @node GETGID + @section @code{GETGID} --- Group ID function + @findex @code{GETGID} intrinsic + @cindex GETGID + + @table @asis + @item @emph{Description}: + Returns the numerical group ID of the current process. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + function + + @item @emph{Syntax}: + @code{I = GETGID()} + + @item @emph{Return value}: + The return value of @code{GETGID} is an @code{INTEGER} of the default + kind. + + + @item @emph{Example}: + See @code{GETPID} for an example. + + @end table + + + + @node GETPID + @section @code{GETPID} --- Process ID function + @findex @code{GETPID} intrinsic + @cindex GETPID + + @table @asis + @item @emph{Description}: + Returns the process numerical identificator of the current process. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + function + + @item @emph{Syntax}: + @code{I = GETPID()} + + @item @emph{Return value}: + The return value of @code{GETPID} is an @code{INTEGER} of the default + kind. + + + @item @emph{Example}: + @smallexample + program info + print *, "The current process ID is ", getpid() + print *, "Your numerical user ID is ", getuid() + print *, "Your numerical group ID is ", getgid() + end program info + @end smallexample + + @end table + + + + @node GETUID + @section @code{GETUID} --- User ID function + @findex @code{GETUID} intrinsic + @cindex GETUID + + @table @asis + @item @emph{Description}: + Returns the numerical user ID of the current process. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + function + + @item @emph{Syntax}: + @code{GETUID()} + + @item @emph{Return value}: + The return value of @code{GETUID} is an @code{INTEGER} of the default + kind. + + + @item @emph{Example}: + See @code{GETPID} for an example. + + @end table + + + + @node HUGE + @section @code{HUGE} --- Largest number of a kind + @findex @code{HUGE} intrinsic + @cindex huge + + @table @asis + @item @emph{Description}: + @code{HUGE(X)} returns the largest number that is not an infinity in + the model of the type of @code{X}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{Y = HUGE(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab shall be of type @code{REAL} or @code{INTEGER}. + @end multitable + + @item @emph{Return value}: + The return value is of the same type and kind as @var{X} + + @item @emph{Example}: + @smallexample + program test_huge_tiny + print *, huge(0), huge(0.0), huge(0.0d0) + print *, tiny(0.0), tiny(0.0d0) + end program test_huge_tiny + @end smallexample + @end table + + + + @node IACHAR + @section @code{IACHAR} --- Code in @acronym{ASCII} collating sequence + @findex @code{IACHAR} intrinsic + @cindex @acronym{ASCII} collating sequence + + @table @asis + @item @emph{Description}: + @code{IACHAR(C)} returns the code for the @acronym{ASCII} character + in the first character position of @code{C}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{I = IACHAR(C)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{C} @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)} + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER} and of the default integer + kind. + + @item @emph{Example}: + @smallexample + program test_iachar + integer i + i = iachar(' ') + end program test_iachar + @end smallexample + @end table + + + + @node ICHAR + @section @code{ICHAR} --- Character-to-integer conversion function + @findex @code{ICHAR} intrinsic + + @table @asis + @item @emph{Description}: + @code{ICHAR(C)} returns the code for the character in the first character + position of @code{C} in the system's native character set. + The correspondence between character and their codes is not necessarily + the same between GNU Fortran implementations. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{I = ICHAR(C)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{C} @tab Shall be a scalar @code{CHARACTER}, with @code{INTENT(IN)} + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER} and of the default integer + kind. + + @item @emph{Example}: + @smallexample + program test_ichar + integer i + i = ichar(' ') + end program test_ichar + @end smallexample + + @item @emph{Note}: + No intrinsic exists to convert a printable character string to a numerical + value. For example, there is no intrinsic that, given the @code{CHARACTER} + value 154, returns an @code{INTEGER} or @code{REAL} value with the + value 154. + + Instead, you can use internal-file I/O to do this kind of conversion. For + example: + @smallexample + program read_val + integer value + character(len=10) string + + string = '154' + read (string,'(I10)') value + print *, value + end program read_val + @end smallexample + @end table + + @node IDATE + @section @code{IDATE} --- Get current local time subroutine (day/month/year) + @findex @code{IDATE} intrinsic + + @table @asis + @item @emph{Description}: + @code{IDATE(TARRAY)} Fills @var{TARRAY} with the numerical values at the + current local time. The day (in the range 1-31), month (in the range 1-12), + and year appear in elements 1, 2, and 3 of @var{TARRAY}, respectively. + The year has four significant digits. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + subroutine + + @item @emph{Syntax}: + @code{CALL IDATE(TARRAY)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{TARRAY} @tab The type shall be @code{INTEGER, DIMENSION(3)} and + the kind shall be the default integer kind. + @end multitable + + @item @emph{Return value}: + Does not return. + + @item @emph{Example}: + @smallexample + program test_idate + integer, dimension(3) :: tarray + call idate(tarray) + print *, tarray(1) + print *, tarray(2) + print *, tarray(3) + end program test_idate + @end smallexample + @end table + + + @node IRAND + @section @code{IRAND} --- Integer pseudo-random number + @findex @code{IRAND} intrinsic + @cindex random number + + @table @asis + @item @emph{Description}: + @code{IRAND(FLAG)} returns a pseudo-random number from a uniform + distribution between 0 and a system-dependent limit (which is in most + cases 2147483647). If @var{FLAG} is 0, the next number + in the current sequence is returned; if @var{FLAG} is 1, the generator + is restarted by @code{CALL SRAND(0)}; if @var{FLAG} has any other value, + it is used as a new seed with @code{SRAND}. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + non-elemental function + + @item @emph{Syntax}: + @code{I = IRAND(FLAG)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{FLAG} @tab shall be a scalar @code{INTEGER} of kind 4. + @end multitable + + @item @emph{Return value}: + The return value is of @code{INTEGER(kind=4)} type. + + @item @emph{Example}: + @smallexample + program test_irand + integer,parameter :: seed = 86456 + + call srand(seed) + print *, irand(), irand(), irand(), irand() + print *, irand(seed), irand(), irand(), irand() + end program test_irand + @end smallexample + + @end table + + @node ITIME + @section @code{ITIME} --- Get current local time subroutine (hour/minutes/seconds) + @findex @code{ITIME} intrinsic + + @table @asis + @item @emph{Description}: + @code{IDATE(TARRAY)} Fills @var{TARRAY} with the numerical values at the + current local time. The hour (in the range 1-24), minute (in the range 1-60), + and seconds (in the range 1-60) appear in elements 1, 2, and 3 of @var{TARRAY}, + respectively. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + subroutine + + @item @emph{Syntax}: + @code{CALL ITIME(TARRAY)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{TARRAY} @tab The type shall be @code{INTEGER, DIMENSION(3)} + and the kind shall be the default integer kind. + @end multitable + + @item @emph{Return value}: + Does not return. + + + @item @emph{Example}: + @smallexample + program test_itime + integer, dimension(3) :: tarray + call itime(tarray) + print *, tarray(1) + print *, tarray(2) + print *, tarray(3) + end program test_itime + @end smallexample + @end table + + + @node KIND + @section @code{KIND} --- Kind of an entity + @findex @code{KIND} intrinsic + + @table @asis + @item @emph{Description}: + @code{KIND(X)} returns the kind value of the entity @var{X}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + inquiry function + + @item @emph{Syntax}: + @code{K = KIND(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab Shall be of type @code{LOGICAL}, @code{INTEGER}, + @code{REAL}, @code{COMPLEX} or @code{CHARACTER}. + @end multitable + + @item @emph{Return value}: + The return value is a scalar of type @code{INTEGER} and of the default + integer kind. + + @item @emph{Example}: + @smallexample + program test_kind + integer,parameter :: kc = kind(' ') + integer,parameter :: kl = kind(.true.) + + print *, "The default character kind is ", kc + print *, "The default logical kind is ", kl + end program test_kind + @end smallexample + + @end table + + + @node LOC @section @code{LOC} --- Returns the address of a variable @findex @code{LOC} intrinsic *************** end program test_malloc *** 3161,3166 **** --- 3670,4134 ---- @end table + + @node MAXEXPONENT + @section @code{MAXEXPONENT} --- Maximum exponent of a real kind + @findex @code{MAXEXPONENT} intrinsic + @cindex MAXEXPONENT + + @table @asis + @item @emph{Description}: + @code{MAXEXPONENT(X)} returns the maximum exponent in the model of the + type of @code{X}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{I = MAXEXPONENT(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab shall be of type @code{REAL}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER} and of the default integer + kind. + + @item @emph{Example}: + @smallexample + program exponents + real(kind=4) :: x + real(kind=8) :: y + + print *, minexponent(x), maxexponent(x) + print *, minexponent(y), maxexponent(y) + end program exponents + @end smallexample + @end table + + + + @node MINEXPONENT + @section @code{MINEXPONENT} --- Minimum exponent of a real kind + @findex @code{MINEXPONENT} intrinsic + @cindex MINEXPONENT + + @table @asis + @item @emph{Description}: + @code{MINEXPONENT(X)} returns the minimum exponent in the model of the + type of @code{X}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{I = MINEXPONENT(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab shall be of type @code{REAL}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER} and of the default integer + kind. + + @item @emph{Example}: + See @code{MAXEXPONENT} for an example. + @end table + + + + @node MOD + @section @code{MOD} --- Remainder function + @findex @code{MOD} intrinsic + @findex @code{AMOD} intrinsic + @findex @code{DMOD} intrinsic + @cindex remainder + + @table @asis + @item @emph{Description}: + @code{MOD(A,P)} computes the remainder of the division of A by P. It is + calculated as @code{A - (INT(A/P) * P)}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{X = MOD(A,P)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{A} @tab shall be a scalar of type @code{INTEGER} or @code{REAL} + @item @var{P} @tab shall be a scalar of the same type as @var{A} and not + equal to zero + @end multitable + + @item @emph{Return value}: + The kind of the return value is the result of cross-promoting + the kinds of the arguments. + + @item @emph{Example}: + @smallexample + program test_mod + print *, mod(17,3) + print *, mod(17.5,5.5) + print *, mod(17.5d0,5.5) + print *, mod(17.5,5.5d0) + + print *, mod(-17,3) + print *, mod(-17.5,5.5) + print *, mod(-17.5d0,5.5) + print *, mod(-17.5,5.5d0) + + print *, mod(17,-3) + print *, mod(17.5,-5.5) + print *, mod(17.5d0,-5.5) + print *, mod(17.5,-5.5d0) + end program test_mod + @end smallexample + + @item @emph{Specific names}: + @multitable @columnfractions .24 .24 .24 .24 + @item Name @tab Arguments @tab Return type @tab Option + @item @code{AMOD(A,P)} @tab @code{REAL(4)} @tab @code{REAL(4)} @tab f95, gnu + @item @code{DMOD(A,P)} @tab @code{REAL(8)} @tab @code{REAL(8)} @tab f95, gnu + @end multitable + @end table + + + + @node MODULO + @section @code{MODULO} --- Modulo function + @findex @code{MODULO} intrinsic + @cindex modulo + + @table @asis + @item @emph{Description}: + @code{MODULO(A,P)} computes the @var{A} modulo @var{P}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{X = MODULO(A,P)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{A} @tab shall be a scalar of type @code{INTEGER} or @code{REAL} + @item @var{P} @tab shall be a scalar of the same type and kind as @var{A} + @end multitable + + @item @emph{Return value}: + The type and kind of the result are those of the arguments. + @table @asis + @item If @var{A} and @var{P} are of type @code{INTEGER}: + @code{MODULO(A,P)} has the value @var{R} such that @code{A=Q*P+R}, where + @var{Q} is an integer and @var{R} is between 0 (inclusive) and @var{P} + (exclusive). + @item If @var{A} and @var{P} are of type @code{REAL}: + @code{MODULO(A,P)} has the value of @code{A - FLOOR (A / P) * P}. + @end table + In all cases, if @var{P} is zero the result is processor-dependent. + + @item @emph{Example}: + @smallexample + program test_mod + print *, modulo(17,3) + print *, modulo(17.5,5.5) + + print *, modulo(-17,3) + print *, modulo(-17.5,5.5) + + print *, modulo(17,-3) + print *, modulo(17.5,-5.5) + end program test_mod + @end smallexample + + @item @emph{Specific names}: + @multitable @columnfractions .24 .24 .24 .24 + @item Name @tab Arguments @tab Return type @tab Option + @item @code{AMOD(A,P)} @tab @code{REAL(4)} @tab @code{REAL(4)} @tab f95, gnu + @item @code{DMOD(A,P)} @tab @code{REAL(8)} @tab @code{REAL(8)} @tab f95, gnu + @end multitable + @end table + + + + @node NEAREST + @section @code{NEAREST} --- Nearest representable number + @findex @code{NEAREST} intrinsic + @cindex processor-representable number + + @table @asis + @item @emph{Description}: + @code{NEAREST(X, S)} returns the processor-representable number nearest + to @code{X} in the direction indicated by the sign of @code{S}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{Y = NEAREST(X, S)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab shall be of type @code{REAL}. + @item @var{S} @tab (Optional) shall be of type @code{REAL} and + not equal to zero. + @end multitable + + @item @emph{Return value}: + The return value is of the same type as @code{X}. If @code{S} is + positive, @code{NEAREST} returns the processor-representable number + greater than @code{X} and nearest to it. If @code{S} is negative, + @code{NEAREST} returns the processor-representable number smaller than + @code{X} and nearest to it. + + @item @emph{Example}: + @smallexample + program test_nearest + real :: x, y + x = nearest(42.0, 1.0) + y = nearest(42.0, -1.0) + write (*,"(3(G20.15))") x, y, x - y + end program test_nearest + @end smallexample + @end table + + + + @node NINT + @section @code{NINT} --- Nearest whole number + @findex @code{NINT} intrinsic + @findex @code{IDNINT} intrinsic + @cindex whole number + + @table @asis + @item @emph{Description}: + @code{NINT(X)} rounds its argument to the nearest whole number. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{X = NINT(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type of the argument shall be @code{REAL}. + @end multitable + + @item @emph{Return value}: + Returns @var{A} with the fractional portion of its magnitude eliminated by + rounding to the nearest whole number and with its sign preserved, + converted to an @code{INTEGER} of the default kind. + + @item @emph{Example}: + @smallexample + program test_nint + real(4) x4 + real(8) x8 + x4 = 1.234E0_4 + x8 = 4.321_8 + print *, nint(x4), idnint(x8) + end program test_nint + @end smallexample + + @item @emph{Specific names}: + @multitable @columnfractions .33 .33 .33 + @item Name @tab Argument @tab Option + @item @code{IDNINT(X)} @tab @code{REAL(8)} @tab f95, gnu + @end multitable + @end table + + + + @node PRECISION + @section @code{PRECISION} --- Decimal precision of a real kind + @findex @code{PRECISION} intrinsic + @cindex PRECISION + + @table @asis + @item @emph{Description}: + @code{PRECISION(X)} returns the decimal precision in the model of the + type of @code{X}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{I = PRECISION(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab shall be of type @code{REAL} or @code{COMPLEX}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER} and of the default integer + kind. + + @item @emph{Example}: + @smallexample + program prec_and_range + real(kind=4) :: x(2) + complex(kind=8) :: y + + print *, precision(x), range(x) + print *, precision(y), range(y) + end program prec_and_range + @end smallexample + @end table + + + + @node RADIX + @section @code{RADIX} --- Base of a model number + @findex @code{RADIX} intrinsic + @cindex base + + @table @asis + @item @emph{Description}: + @code{RADIX(X)} returns the base of the model representing the entity @var{X}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + inquiry function + + @item @emph{Syntax}: + @code{R = RADIX(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab Shall be of type @code{INTEGER} or @code{REAL} + @end multitable + + @item @emph{Return value}: + The return value is a scalar of type @code{INTEGER} and of the default + integer kind. + + @item @emph{Example}: + @smallexample + program test_radix + print *, "The radix for the default integer kind is", radix(0) + print *, "The radix for the default real kind is", radix(0.0) + end program test_radix + @end smallexample + + @end table + + + + @node RAND + @section @code{RAND} --- Real pseudo-random number + @findex @code{RAND} intrinsic + @findex @code{RAN} intrinsic + @cindex random number + + @table @asis + @item @emph{Description}: + @code{RAND(FLAG)} returns a pseudo-random number from a uniform + distribution between 0 and 1. If @var{FLAG} is 0, the next number + in the current sequence is returned; if @var{FLAG} is 1, the generator + is restarted by @code{CALL SRAND(0)}; if @var{FLAG} has any other value, + it is used as a new seed with @code{SRAND}. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + non-elemental function + + @item @emph{Syntax}: + @code{X = RAND(FLAG)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{FLAG} @tab shall be a scalar @code{INTEGER} of kind 4. + @end multitable + + @item @emph{Return value}: + The return value is of @code{REAL} type and the default kind. + + @item @emph{Example}: + @smallexample + program test_rand + integer,parameter :: seed = 86456 + + call srand(seed) + print *, rand(), rand(), rand(), rand() + print *, rand(seed), rand(), rand(), rand() + end program test_rand + @end smallexample + + @item @emph{Note}: + For compatibility with HP FORTRAN 77/iX, the @code{RAN} intrinsic is + provided as an alias for @code{RAND}. + + @end table + + + + @node RANGE + @section @code{RANGE} --- Decimal exponent range of a real kind + @findex @code{RANGE} intrinsic + @cindex RANGE + + @table @asis + @item @emph{Description}: + @code{RANGE(X)} returns the decimal exponent range in the model of the + type of @code{X}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{I = RANGE(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab shall be of type @code{REAL} or @code{COMPLEX}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER} and of the default integer + kind. + + @item @emph{Example}: + See @code{PRECISION} for an example. + @end table + + + @node REAL @section @code{REAL} --- Convert to real type @findex @code{REAL} intrinsic *************** variable. *** 3215,3284 **** program test_real complex :: x = (1.0, 2.0) print *, real(x), real(x,8), realpart(x) ! end program test_real @end smallexample @end table ! @node SIGNAL ! @section @code{SIGNAL} --- Signal handling subroutine (or function) ! @findex @code{SIGNAL} intrinsic ! @cindex SIGNAL subroutine @table @asis @item @emph{Description}: ! @code{SIGNAL(NUMBER, HANDLER [, STATUS])} causes external subroutine ! @var{HANDLER} to be executed with a single integer argument when signal ! @var{NUMBER} occurs. If @var{HANDLER} is an integer, it can be used to ! turn off handling of signal @var{NUMBER} or revert to its default ! action. See @code{signal(2)}. ! ! If @code{SIGNAL} is called as a subroutine and the @var{STATUS} argument ! is supplied, it is set to the value returned by @code{signal(2)}. @item @emph{Option}: ! gnu @item @emph{Class}: ! subroutine, non-elemental function @item @emph{Syntax}: ! @multitable @columnfractions .30 .80 ! @item @code{CALL ALARM(NUMBER, HANDLER)} ! @item @code{CALL ALARM(NUMBER, HANDLER, STATUS)} ! @item @code{STATUS = ALARM(NUMBER, HANDLER)} @end multitable @item @emph{Arguments}: @multitable @columnfractions .15 .80 ! @item @var{NUMBER} @tab shall be a scalar integer, with @code{INTENT(IN)} ! @item @var{HANDLER}@tab Signal handler (@code{INTEGER FUNCTION} or ! @code{SUBROUTINE}) or dummy/global @code{INTEGER} scalar. ! @code{INTEGER}. It is @code{INTENT(IN)}. ! @item @var{STATUS} @tab (Optional) @var{STATUS} shall be a scalar ! integer. It has @code{INTENT(OUT)}. @end multitable @item @emph{Return value}: ! The @code{SIGNAL} functions returns the value returned by @code{signal(2)}. @item @emph{Example}: @smallexample ! program test_signal ! intrinsic signal ! external handler_print ! call signal (12, handler_print) ! call signal (10, 1) ! call sleep (30) ! end program test_signal @end smallexample @end table @node SECNDS @section @code{SECNDS} --- Time subroutine --- 4183,4376 ---- program test_real complex :: x = (1.0, 2.0) print *, real(x), real(x,8), realpart(x) ! end program test_real @end smallexample @end table ! @node RRSPACING ! @section @code{RRSPACING} --- Reciprocal of the relative spacing ! @findex @code{RRSPACING} intrinsic @table @asis @item @emph{Description}: ! @code{RRSPACING(X)} returns the reciprocal of the relative spacing of ! model numbers near @var{X}. @item @emph{Option}: ! f95, gnu @item @emph{Class}: ! elemental function @item @emph{Syntax}: ! @code{Y = RRSPACING(X)} ! ! @item @emph{Arguments}: ! @multitable @columnfractions .15 .80 ! @item @var{X} @tab shall be of type @code{REAL}. @end multitable + @item @emph{Return value}: + The return value is of the same type and kind as @var{X}. + The value returned is equal to + @code{ABS(FRACTION(X)) * FLOAT(RADIX(X))**DIGITS(X)}. + + @end table + + + + @node SCALE + @section @code{SCALE} --- Scale a real value + @findex @code{SCALE} intrinsic + + @table @asis + @item @emph{Description}: + @code{SCALE(X,I)} returns @code{X * RADIX(X)**I}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{Y = SCALE(X, I)} + @item @emph{Arguments}: @multitable @columnfractions .15 .80 ! @item @var{X} @tab The type of the argument shall be a @code{REAL}. ! @item @var{I} @tab The type of the argument shall be a @code{INTEGER}. @end multitable @item @emph{Return value}: ! The return value is of the same type and kind as @var{X}. ! Its value is @code{X * RADIX(X)**I}. @item @emph{Example}: @smallexample ! program test_scale ! real :: x = 178.1387e-4 ! integer :: i = 5 ! print *, scale(x,i), x*radix(x)**i ! end program test_scale ! @end smallexample ! @end table ! ! ! @node SELECTED_INT_KIND ! @section @code{SELECTED_INT_KIND} --- Choose integer kind ! @findex @code{SELECTED_INT_KIND} intrinsic ! @cindex integer kind ! ! @table @asis ! @item @emph{Description}: ! @code{SELECTED_INT_KIND(I)} return the kind value of the smallest integer ! type that can represent all values ranging from @math{-10^I} (exclusive) ! to @math{10^I} (exclusive). If there is no integer kind that accomodates ! this range, @code{SELECTED_INT_KIND} returns @math{-1}. ! ! @item @emph{Option}: ! f95 ! ! @item @emph{Class}: ! transformational function ! ! @item @emph{Syntax}: ! @multitable @columnfractions .30 .80 ! @item @code{J = SELECTED_INT_KIND(I)} ! @end multitable ! ! @item @emph{Arguments}: ! @multitable @columnfractions .15 .80 ! @item @var{I} @tab shall be a scalar and of type @code{INTEGER}. ! @end multitable ! ! @item @emph{Example}: ! @smallexample ! program large_integers ! integer,parameter :: k5 = selected_int_kind(5) ! integer,parameter :: k15 = selected_int_kind(15) ! integer(kind=k5) :: i5 ! integer(kind=k15) :: i15 ! ! print *, huge(i5), huge(i15) ! ! ! The following inequalities are always true ! print *, huge(i5) >= 10_k5**5-1 ! print *, huge(i15) >= 10_k15**15-1 ! end program large_integers @end smallexample @end table + @node SELECTED_REAL_KIND + @section @code{SELECTED_REAL_KIND} --- Choose real kind + @findex @code{SELECTED_REAL_KIND} intrinsic + @cindex real kind + + @table @asis + @item @emph{Description}: + @code{SELECTED_REAL_KIND(P,R)} return the kind value of a real data type + with decimal precision greater of at least @code{P} digits and exponent + range greater at least @code{R}. + + @item @emph{Option}: + f95 + + @item @emph{Class}: + transformational function + + @item @emph{Syntax}: + @multitable @columnfractions .30 .80 + @item @code{I = SELECTED_REAL_KIND(P,R)} + @end multitable + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{P} @tab (Optional) shall be a scalar and of type @code{INTEGER}. + @item @var{R} @tab (Optional) shall be a scalar and of type @code{INTEGER}. + @end multitable + At least one argument shall be present. + + @item @emph{Return value}: + + @code{SELECTED_REAL_KIND} returns the value of the kind type parameter of + a real data type with decimal precision of at least @code{P} digits and a + decimal exponent range of at least @code{R}. If more than one real data + type meet the criteria, the kind of the data type with the smallest + decimal precision is returned. If no real data type matches the criteria, + the result is + @table @asis + @item -1 if the processor does not support a real data type with a + precision greater than or equal to @code{P} + @item -2 if the processor does not support a real type with an exponent + range greater than or equal to @code{R} + @item -3 if neither is supported. + @end table + + @item @emph{Example}: + @smallexample + program real_kinds + integer,parameter :: p6 = selected_real_kind(6) + integer,parameter :: p10r100 = selected_real_kind(10,100) + integer,parameter :: r400 = selected_real_kind(r=400) + real(kind=p6) :: x + real(kind=p10r100) :: y + real(kind=r400) :: z + + print *, precision(x), range(x) + print *, precision(y), range(y) + print *, precision(z), range(z) + end program real_kinds + @end smallexample + @end table + + @node SECNDS @section @code{SECNDS} --- Time subroutine *************** end program test_secnds *** 3327,3332 **** --- 4419,4581 ---- + @node SET_EXPONENT + @section @code{SET_EXPONENT} --- Set the exponent of the model + @findex @code{SET_EXPONENT} intrinsic + @cindex exponent + + @table @asis + @item @emph{Description}: + @code{SET_EXPONENT(X, I)} returns the real number whose fractional part + is that that of @var{X} and whose exponent part if @var{I}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{Y = SET_EXPONENT(X, I)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab shall be of type @code{REAL}. + @item @var{I} @tab shall be of type @code{INTEGER}. + @end multitable + + @item @emph{Return value}: + The return value is of the same type and kind as @var{X}. + The real number whose fractional part + is that that of @var{X} and whose exponent part if @var{I} is returned; + it is @code{FRACTION(X) * RADIX(X)**I}. + + @item @emph{Example}: + @smallexample + program test_setexp + real :: x = 178.1387e-4 + integer :: i = 17 + print *, set_exponent(x), fraction(x) * radix(x)**i + end program test_setexp + @end smallexample + + @end table + + + + @node SIGN + @section @code{SIGN} --- Sign copying function + @findex @code{SIGN} intrinsic + @findex @code{ISIGN} intrinsic + @findex @code{DSIGN} intrinsic + @cindex sign copying + + @table @asis + @item @emph{Description}: + @code{SIGN(A,B)} returns the value of @var{A} with the sign of @var{B}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{X = SIGN(A,B)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{A} @tab shall be a scalar of type @code{INTEGER} or @code{REAL} + @item @var{B} @tab shall be a scalar of the same type and kind as @var{A} + @end multitable + + @item @emph{Return value}: + The kind of the return value is that of @var{A} and @var{B}. + If @math{B\ge 0} then the result is @code{ABS(A)}, else + it is @code{-ABS(A)}. + + @item @emph{Example}: + @smallexample + program test_sign + print *, sign(-12,1) + print *, sign(-12,0) + print *, sign(-12,-1) + + print *, sign(-12.,1.) + print *, sign(-12.,0.) + print *, sign(-12.,-1.) + end program test_sign + @end smallexample + + @item @emph{Specific names}: + @multitable @columnfractions .24 .24 .24 .24 + @item Name @tab Arguments @tab Return type @tab Option + @item @code{ISIGN(A,P)} @tab @code{INTEGER(4)} @tab @code{INTEGER(4)} @tab f95, gnu + @item @code{DSIGN(A,P)} @tab @code{REAL(8)} @tab @code{REAL(8)} @tab f95, gnu + @end multitable + @end table + + + + @node SIGNAL + @section @code{SIGNAL} --- Signal handling subroutine (or function) + @findex @code{SIGNAL} intrinsic + @cindex SIGNAL subroutine + + @table @asis + @item @emph{Description}: + @code{SIGNAL(NUMBER, HANDLER [, STATUS])} causes external subroutine + @var{HANDLER} to be executed with a single integer argument when signal + @var{NUMBER} occurs. If @var{HANDLER} is an integer, it can be used to + turn off handling of signal @var{NUMBER} or revert to its default + action. See @code{signal(2)}. + + If @code{SIGNAL} is called as a subroutine and the @var{STATUS} argument + is supplied, it is set to the value returned by @code{signal(2)}. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + subroutine, non-elemental function + + @item @emph{Syntax}: + @multitable @columnfractions .30 .80 + @item @code{CALL ALARM(NUMBER, HANDLER)} + @item @code{CALL ALARM(NUMBER, HANDLER, STATUS)} + @item @code{STATUS = ALARM(NUMBER, HANDLER)} + @end multitable + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{NUMBER} @tab shall be a scalar integer, with @code{INTENT(IN)} + @item @var{HANDLER}@tab Signal handler (@code{INTEGER FUNCTION} or + @code{SUBROUTINE}) or dummy/global @code{INTEGER} scalar. + @code{INTEGER}. It is @code{INTENT(IN)}. + @item @var{STATUS} @tab (Optional) @var{STATUS} shall be a scalar + integer. It has @code{INTENT(OUT)}. + @end multitable + + @item @emph{Return value}: + The @code{SIGNAL} functions returns the value returned by @code{signal(2)}. + + @item @emph{Example}: + @smallexample + program test_signal + intrinsic signal + external handler_print + + call signal (12, handler_print) + call signal (10, 1) + + call sleep (30) + end program test_signal + @end smallexample + @end table + + + + @node SIN @section @code{SIN} --- Sine function @findex @code{SIN} intrinsic *************** end program test_sinh *** 3421,3426 **** --- 4670,4707 ---- + @node SNGL + @section @code{SNGL} --- Convert double precision real to default real + @findex @code{SNGL} intrinsic + @cindex sngl + + @table @asis + @item @emph{Description}: + @code{SNGL(A)} converts the double precision real @var{A} + to a default real value. This is an archaic form of @code{REAL} + that is specific to one type for @var{A}. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + function + + @item @emph{Syntax}: + @code{X = SNGL(A)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{A} @tab The type shall be a double precision @code{REAL}. + @end multitable + + @item @emph{Return value}: + The return value is of type default @code{REAL}. + + @end table + + + @node SQRT @section @code{SQRT} --- Square-root function @findex @code{SQRT} intrinsic *************** end program test_sqrt *** 3475,3480 **** --- 4756,4805 ---- + @node SRAND + @section @code{SRAND} --- Reinitialize the random number generator + @findex @code{SRAND} intrinsic + @cindex random number + + @table @asis + @item @emph{Description}: + @code{SRAND} reinitializes the pseudo-random number generator + called by @code{RAND} and @code{IRAND}. The new seed used by the + generator is specified by the required argument @var{SEED}. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + non-elemental subroutine + + @item @emph{Syntax}: + @code{CALL SRAND(SEED)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{SEED} @tab shall be a scalar @code{INTEGER(kind=4)}. + @end multitable + + @item @emph{Return value}: + Does not return. + + @item @emph{Example}: + See @code{RAND} and @code{IRAND} for examples. + + @item @emph{Notes}: + The Fortran 2003 standard specifies the intrinsic @code{RANDOM_SEED} to + initialize the pseudo-random numbers generator and @code{RANDOM_NUMBER} + to generate pseudo-random numbers. Please note that in + @command{gfortran}, these two sets of intrinsics (@code{RAND}, + @code{IRAND} and @code{SRAND} on the one hand, @code{RANDOM_NUMBER} and + @code{RANDOM_SEED} on the other hand) access two independent + pseudo-random numbers generators. + + @end table + + + @node TAN @section @code{TAN} --- Tangent function @findex @code{TAN} intrinsic *************** end program test_tanh *** 3565,3574 **** ! @comment sub flush ! @comment ! @comment gen fraction ! @comment @comment gen fstat @comment sub fstat @comment --- 4890,4928 ---- ! @node TINY ! @section @code{TINY} --- Smallest positive number of a real kind ! @findex @code{TINY} intrinsic ! @cindex tiny ! ! @table @asis ! @item @emph{Description}: ! @code{TINY(X)} returns the smallest positive (non zero) number ! in the model of the type of @code{X}. ! ! @item @emph{Option}: ! f95, gnu ! ! @item @emph{Class}: ! elemental function ! ! @item @emph{Syntax}: ! @code{Y = TINY(X)} ! ! @item @emph{Arguments}: ! @multitable @columnfractions .15 .80 ! @item @var{X} @tab shall be of type @code{REAL}. ! @end multitable ! ! @item @emph{Return value}: ! The return value is of the same type and kind as @var{X} ! ! @item @emph{Example}: ! See @code{HUGE} for an example. ! @end table ! ! ! @comment gen fstat @comment sub fstat @comment *************** end program test_tanh *** 3579,3600 **** @comment @comment sub getenv @comment - @comment gen getgid - @comment - @comment gen getpid - @comment - @comment gen getuid - @comment @comment sub get_command @comment @comment sub get_command_argument @comment @comment sub get_environment_variable @comment - @comment gen huge - @comment - @comment gen iachar - @comment @comment gen iand @comment @comment gen iargc --- 4933,4944 ---- *************** end program test_tanh *** 3605,3612 **** @comment @comment gen ibset @comment - @comment gen ichar - @comment @comment gen ieor @comment @comment gen index --- 4949,4954 ---- *************** end program test_tanh *** 3617,3630 **** @comment @comment gen ior @comment - @comment gen irand - @comment @comment gen ishft @comment @comment gen ishftc @comment - @comment gen kind - @comment @comment gen lbound @comment @comment gen len --- 4959,4968 ---- *************** end program test_tanh *** 3650,3657 **** @comment max1 @comment dmax1 @comment - @comment gen maxexponent - @comment @comment gen maxloc @comment @comment gen maxval --- 4988,4993 ---- *************** end program test_tanh *** 3665,3749 **** @comment min1 @comment dmin1 @comment - @comment gen minexponent - @comment @comment gen minloc @comment @comment gen minval @comment - @comment gen mod - @comment amod - @comment dmod - @comment - @comment gen modulo - @comment @comment sub mvbits @comment - @comment gen nearest - @comment - @comment gen nint - @comment idnint - @comment @comment gen not @comment @comment gen null @comment @comment gen pack @comment ! @comment gen precision @comment @comment gen present @comment @comment gen product @comment - @comment gen radix - @comment - @comment gen rand - @comment ran - @comment @comment sub random_number @comment @comment sub random_seed @comment - @comment gen range - @comment - @comment gen real - @comment float - @comment sngl - @comment @comment gen repeat @comment @comment gen reshape @comment - @comment gen rrspacing - @comment - @comment gen scale - @comment @comment gen scan @comment @comment gen second @comment sub second @comment - @comment gen selected_int_kind - @comment - @comment gen selected_real_kind - @comment - @comment gen set_exponent - @comment @comment gen shape @comment - @comment gen sign - @comment isign - @comment dsign - @comment @comment gen size @comment @comment gen spacing @comment @comment gen spread @comment - @comment sub srand - @comment @comment gen stat @comment sub stat @comment --- 5001,5045 ---- @comment min1 @comment dmin1 @comment @comment gen minloc @comment @comment gen minval @comment @comment sub mvbits @comment @comment gen not @comment @comment gen null @comment @comment gen pack @comment ! @comment gen perror @comment @comment gen present @comment @comment gen product @comment @comment sub random_number @comment @comment sub random_seed @comment @comment gen repeat @comment @comment gen reshape @comment @comment gen scan @comment @comment gen second @comment sub second @comment @comment gen shape @comment @comment gen size @comment @comment gen spacing @comment @comment gen spread @comment @comment gen stat @comment sub stat @comment *************** end program test_tanh *** 3754,3761 **** @comment @comment sub system_clock @comment - @comment gen tiny - @comment @comment gen transfer @comment @comment gen transpose --- 5050,5055 ---- *************** end program test_tanh *** 3773,3776 **** @comment gen unpack @comment @comment gen verify - --- 5067,5069 ---- diff -Nrcpad gcc-4.1.1/gcc/fortran/invoke.texi gcc-4.1.2/gcc/fortran/invoke.texi *** gcc-4.1.1/gcc/fortran/invoke.texi Fri Apr 7 21:07:52 2006 --- gcc-4.1.2/gcc/fortran/invoke.texi Wed Jun 28 05:36:08 2006 *************** by type. Explanations are in the follow *** 122,128 **** -ffixed-line-length-@var{n} -ffixed-line-length-none @gol -ffree-line-length-@var{n} -ffree-line-length-none @gol -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol ! -fcray-pointer } @item Warning Options @xref{Warning Options,,Options to Request or Suppress Warnings}. --- 122,128 ---- -ffixed-line-length-@var{n} -ffixed-line-length-none @gol -ffree-line-length-@var{n} -ffree-line-length-none @gol -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol ! -fcray-pointer -frange-check } @item Warning Options @xref{Warning Options,,Options to Request or Suppress Warnings}. *************** Specify that no implicit typing is allow *** 291,296 **** --- 291,305 ---- @item -fcray-pointer Enables the Cray pointer extension, which provides a C-like pointer. + @cindex -frange-check + @cindex options, -frange-check + @item -frange-check + Enable range checking on results of simplification of constant expressions + during compilation. For example, by default, @command{gfortran} will give + an overflow error at compile time when simplifying @code{a = EXP(1000)}. + With @samp{-fno-range-check}, no error will be given and the variable @code{a} + will be assigned the value @code{+Infinity}. + @cindex -std=@var{std} option @cindex option, -std=@var{std} @item -std=@var{std} diff -Nrcpad gcc-4.1.1/gcc/fortran/io.c gcc-4.1.2/gcc/fortran/io.c *** gcc-4.1.1/gcc/fortran/io.c Mon Mar 27 13:17:09 2006 --- gcc-4.1.2/gcc/fortran/io.c Sat Jan 27 17:14:06 2007 *************** next_char (int in_string) *** 135,145 **** c = gfc_next_char_literal (in_string); if (c == '\n') c = '\0'; ! if (mode == MODE_COPY) ! *format_string++ = c; } c = TOUPPER (c); return c; } --- 135,186 ---- c = gfc_next_char_literal (in_string); if (c == '\n') c = '\0'; + } ! if (gfc_option.flag_backslash && c == '\\') ! { ! locus old_locus = gfc_current_locus; ! ! switch (gfc_next_char_literal (1)) ! { ! case 'a': ! c = '\a'; ! break; ! case 'b': ! c = '\b'; ! break; ! case 't': ! c = '\t'; ! break; ! case 'f': ! c = '\f'; ! break; ! case 'n': ! c = '\n'; ! break; ! case 'r': ! c = '\r'; ! break; ! case 'v': ! c = '\v'; ! break; ! case '\\': ! c = '\\'; ! break; ! ! default: ! /* Unknown backslash codes are simply not expanded. */ ! gfc_current_locus = old_locus; ! break; ! } ! ! if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) ! gfc_warning ("Extension: backslash character at %C"); } + if (mode == MODE_COPY) + *format_string++ = c; + c = TOUPPER (c); return c; } *************** resolve_tag (const io_tag * tag, gfc_exp *** 1054,1059 **** --- 1095,1107 ---- return FAILURE; } } + else if (e->ts.type == BT_INTEGER) + { + gfc_error ("scalar '%s' FORMAT tag at %L is not an ASSIGNED " + "variable", gfc_basic_typename (e->ts.type), &e->where); + return FAILURE; + } + return SUCCESS; } else *************** if (condition) \ *** 2323,2328 **** --- 2371,2382 ---- "List directed format(*) is not allowed with a " "ADVANCE=specifier at %L.", &expr->where); + io_constraint (dt->format_expr == NULL + && dt->format_label == NULL + && dt->namelist == NULL, + "the ADVANCE=specifier at %L must appear with an " + "explicit format expression", &expr->where); + if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) { const char * advance = expr->value.character.string; *************** match_io (io_kind k) *** 2373,2379 **** where = gfc_current_locus; comma_flag = 0; current_dt = dt = gfc_getmem (sizeof (gfc_dt)); ! if (gfc_match_char ('(') == MATCH_NO) { where = gfc_current_locus; if (k == M_WRITE) --- 2427,2434 ---- where = gfc_current_locus; comma_flag = 0; current_dt = dt = gfc_getmem (sizeof (gfc_dt)); ! m = gfc_match_char ('('); ! if (m == MATCH_NO) { where = gfc_current_locus; if (k == M_WRITE) *************** match_io (io_kind k) *** 2423,2428 **** --- 2478,2505 ---- dt->io_unit = default_unit (k); goto get_io_list; } + else + { + /* Before issuing an error for a malformed 'print (1,*)' type of + error, check for a default-char-expr of the form ('(I0)'). */ + + if (k == M_PRINT && m == MATCH_YES) + { + /* Reset current locus to get the initial '(' in an expression. */ + gfc_current_locus = where; + dt->format_expr = NULL; + m = match_dt_format (dt); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO || dt->format_expr == NULL) + goto syntax; + + comma_flag = 1; + dt->io_unit = default_unit (k); + goto get_io_list; + } + } /* Match a control list */ if (match_dt_element (k, dt) == MATCH_YES) diff -Nrcpad gcc-4.1.1/gcc/fortran/iresolve.c gcc-4.1.2/gcc/fortran/iresolve.c *** gcc-4.1.1/gcc/fortran/iresolve.c Sat Apr 22 07:13:20 2006 --- gcc-4.1.2/gcc/fortran/iresolve.c Mon Sep 18 06:46:36 2006 *************** gfc_resolve_maxloc (gfc_expr * f, gfc_ex *** 1081,1096 **** gfc_expr * mask) { const char *name; f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; if (dim == NULL) ! f->rank = 1; else { f->rank = array->rank - 1; gfc_resolve_dim_arg (dim); } if (mask) --- 1081,1112 ---- gfc_expr * mask) { const char *name; + int i, j, idim; f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; if (dim == NULL) ! { ! f->rank = 1; ! f->shape = gfc_get_shape (1); ! mpz_init_set_si (f->shape[0], array->rank); ! } else { f->rank = array->rank - 1; gfc_resolve_dim_arg (dim); + if (array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } } if (mask) *************** gfc_resolve_maxval (gfc_expr * f, gfc_ex *** 1125,1130 **** --- 1141,1147 ---- gfc_expr * mask) { const char *name; + int i, j, idim; f->ts = array->ts; *************** gfc_resolve_maxval (gfc_expr * f, gfc_ex *** 1132,1137 **** --- 1149,1166 ---- { f->rank = array->rank - 1; gfc_resolve_dim_arg (dim); + + if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } } if (mask) *************** gfc_resolve_minloc (gfc_expr * f, gfc_ex *** 1188,1203 **** gfc_expr * mask) { const char *name; f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; if (dim == NULL) ! f->rank = 1; else { f->rank = array->rank - 1; gfc_resolve_dim_arg (dim); } if (mask) --- 1217,1248 ---- gfc_expr * mask) { const char *name; + int i, j, idim; f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; if (dim == NULL) ! { ! f->rank = 1; ! f->shape = gfc_get_shape (1); ! mpz_init_set_si (f->shape[0], array->rank); ! } else { f->rank = array->rank - 1; gfc_resolve_dim_arg (dim); + if (array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } } if (mask) *************** gfc_resolve_minval (gfc_expr * f, gfc_ex *** 1232,1237 **** --- 1277,1283 ---- gfc_expr * mask) { const char *name; + int i, j, idim; f->ts = array->ts; *************** gfc_resolve_minval (gfc_expr * f, gfc_ex *** 1239,1244 **** --- 1285,1302 ---- { f->rank = array->rank - 1; gfc_resolve_dim_arg (dim); + + if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } } if (mask) *************** gfc_resolve_spread (gfc_expr * f, gfc_ex *** 1723,1728 **** --- 1781,1803 ---- ? PREFIX("spread_char") : PREFIX("spread")); + if (dim && gfc_is_constant_expr (dim) + && ncopies && gfc_is_constant_expr (ncopies) + && source->shape[0]) + { + int i, idim; + idim = mpz_get_ui (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0; i < (idim - 1); i++) + mpz_init_set (f->shape[i], source->shape[i]); + + mpz_init_set (f->shape[idim - 1], ncopies->value.integer); + + for (i = idim; i < f->rank ; i++) + mpz_init_set (f->shape[i], source->shape[i-1]); + } + + gfc_resolve_dim_arg (dim); gfc_resolve_index (ncopies, 1); } *************** gfc_resolve_alarm_sub (gfc_code * c) *** 2179,2185 **** } void ! gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED) { const char *name; --- 2254,2260 ---- } void ! gfc_resolve_cpu_time (gfc_code * c) { const char *name; *************** gfc_resolve_mvbits (gfc_code * c) *** 2203,2209 **** void ! gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED) { const char *name; int kind; --- 2278,2284 ---- void ! gfc_resolve_random_number (gfc_code * c) { const char *name; int kind; *************** gfc_resolve_etime_sub (gfc_code * c) *** 2294,2299 **** --- 2369,2394 ---- } + /* G77 compatibility subroutines itime() and idate(). */ + + void + gfc_resolve_itime (gfc_code * c) + { + c->resolved_sym = gfc_get_intrinsic_sub_symbol + (gfc_get_string (PREFIX("itime_i%d"), + gfc_default_integer_kind)); + } + + + void + gfc_resolve_idate (gfc_code * c) + { + c->resolved_sym = gfc_get_intrinsic_sub_symbol + (gfc_get_string (PREFIX("idate_i%d"), + gfc_default_integer_kind)); + } + + /* G77 compatibility subroutine second(). */ void diff -Nrcpad gcc-4.1.1/gcc/fortran/lang-specs.h gcc-4.1.2/gcc/fortran/lang-specs.h *** gcc-4.1.1/gcc/fortran/lang-specs.h Fri Jan 27 20:03:59 2006 --- gcc-4.1.2/gcc/fortran/lang-specs.h Sun Jul 2 21:17:05 2006 *************** This file is licensed under the GPL. */ *** 22,28 **** "cc1 -E -lang-fortran -traditional-cpp -D_LANGUAGE_FORTRAN %(cpp_options) \ %{E|M|MM:%(cpp_debug_options)}\ %{!M:%{!MM:%{!E: -o %|.f95 |\n\ ! f951 %|.f95 %(cc1_options) %{J*} %{I*}\ -fpreprocessed %{!fsyntax-only:%(invoke_as)}}}}", 0, 0, 0}, {".f90", "@f95", 0, 0, 0}, {".f95", "@f95", 0, 0, 0}, --- 22,28 ---- "cc1 -E -lang-fortran -traditional-cpp -D_LANGUAGE_FORTRAN %(cpp_options) \ %{E|M|MM:%(cpp_debug_options)}\ %{!M:%{!MM:%{!E: -o %|.f95 |\n\ ! f951 %|.f95 %{!ffixed-form:-ffree-form} %(cc1_options) %{J*} %{I*}\ -fpreprocessed %{!fsyntax-only:%(invoke_as)}}}}", 0, 0, 0}, {".f90", "@f95", 0, 0, 0}, {".f95", "@f95", 0, 0, 0}, diff -Nrcpad gcc-4.1.1/gcc/fortran/lang.opt gcc-4.1.2/gcc/fortran/lang.opt *** gcc-4.1.1/gcc/fortran/lang.opt Fri Apr 7 21:07:52 2006 --- gcc-4.1.2/gcc/fortran/lang.opt Wed Jun 28 05:36:08 2006 *************** fno-backend *** 169,174 **** --- 169,178 ---- Fortran RejectNegative Don't generate code, just do syntax and semantics checking + frange-check + Fortran + Enable range checking during compilation + fpack-derived Fortran Try to layout derived types as compact as possible diff -Nrcpad gcc-4.1.1/gcc/fortran/match.c gcc-4.1.2/gcc/fortran/match.c *** gcc-4.1.1/gcc/fortran/match.c Tue Mar 7 00:06:37 2006 --- gcc-4.1.2/gcc/fortran/match.c Fri Sep 15 16:38:51 2006 *************** gfc_match_if (gfc_statement * if_type) *** 1058,1063 **** --- 1058,1069 ---- gfc_undo_symbols (); gfc_current_locus = old_loc; + /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_NO, continue to + call the various matchers. For MATCH_ERROR, a mangled assignment + was found. */ + if (m == MATCH_ERROR) + return MATCH_ERROR; + gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */ m = gfc_match_pointer_assignment (); *************** gfc_match_allocate (void) *** 1768,1773 **** --- 1774,1782 ---- goto cleanup; } + if (tail->expr->ts.type == BT_DERIVED) + tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived); + if (gfc_match_char (',') != MATCH_YES) break; *************** gfc_match_common (void) *** 2268,2275 **** gsym = gfc_get_gsymbol (name); if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON) { ! gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON", ! sym->name); goto cleanup; } --- 2277,2284 ---- gsym = gfc_get_gsymbol (name); if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON) { ! gfc_error ("Symbol '%s' at %C is already an external symbol " ! " that is not COMMON", name); goto cleanup; } *************** cleanup: *** 2772,2778 **** /* Check that a statement function is not recursive. This is done by looking for the statement function symbol(sym) by looking recursively through its ! expression(e). If a reference to sym is found, true is returned. */ static bool recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) { --- 2781,2791 ---- /* Check that a statement function is not recursive. This is done by looking for the statement function symbol(sym) by looking recursively through its ! expression(e). If a reference to sym is found, true is returned. ! 12.5.4 requires that any variable of function that is implicitly typed ! shall have that type confirmed by any subsequent type declaration. The ! implicit typing is conveniently done here. */ ! static bool recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) { *************** recursive_stmt_fcn (gfc_expr *e, gfc_sym *** 2806,2816 **** --- 2819,2835 ---- && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) return true; + if (e->symtree->n.sym->ts.type == BT_UNKNOWN) + gfc_set_default_type (e->symtree->n.sym, 0, NULL); + break; case EXPR_VARIABLE: if (e->symtree && sym->name == e->symtree->n.sym->name) return true; + + if (e->symtree->n.sym->ts.type == BT_UNKNOWN) + gfc_set_default_type (e->symtree->n.sym, 0, NULL); break; case EXPR_OP: *************** match_case_eos (void) *** 3000,3005 **** --- 3019,3033 ---- if (gfc_match_eos () == MATCH_YES) return MATCH_YES; + + /* If the case construct doesn't have a case-construct-name, we + should have matched the EOS. */ + if (!gfc_current_block ()) + { + gfc_error ("Expected the name of the select case construct at %C"); + return MATCH_ERROR; + } + gfc_gobble_whitespace (); m = gfc_match_name (name); *************** syntax: *** 3354,3359 **** --- 3382,3394 ---- m = MATCH_ERROR; cleanup: + /* Make sure that potential internal function references in the + mask do not get messed up. */ + if (iter->var + && iter->var->expr_type == EXPR_VARIABLE + && iter->var->symtree->n.sym->refs == 1) + iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN; + gfc_current_locus = where; gfc_free_forall_iterator (iter); return m; *************** gfc_match_forall (gfc_statement * st) *** 3546,3554 **** c = gfc_get_code (); *c = new_st; ! ! if (gfc_match_eos () != MATCH_YES) ! goto syntax; gfc_clear_new_st (); new_st.op = EXEC_FORALL; --- 3581,3587 ---- c = gfc_get_code (); *c = new_st; ! c->loc = gfc_current_locus; gfc_clear_new_st (); new_st.op = EXEC_FORALL; diff -Nrcpad gcc-4.1.1/gcc/fortran/matchexp.c gcc-4.1.2/gcc/fortran/matchexp.c *** gcc-4.1.1/gcc/fortran/matchexp.c Sun Feb 12 18:31:40 2006 --- gcc-4.1.2/gcc/fortran/matchexp.c Sun May 28 19:46:22 2006 *************** next_operator (gfc_intrinsic_op t) *** 122,127 **** --- 122,147 ---- } + /* Call the INTRINSIC_PARENTHESES function. This is both + used explicitly, as below, or by resolve.c to generate + temporaries. */ + gfc_expr * + gfc_get_parentheses (gfc_expr *e) + { + gfc_expr *e2; + + e2 = gfc_get_expr(); + e2->expr_type = EXPR_OP; + e2->ts = e->ts; + e2->rank = e->rank; + e2->where = e->where; + e2->value.op.operator = INTRINSIC_PARENTHESES; + e2->value.op.op1 = e; + e2->value.op.op2 = NULL; + return e2; + } + + /* Match a primary expression. */ static match *************** match_primary (gfc_expr ** result) *** 166,183 **** if(!gfc_numeric_ts(&e->ts)) *result = e; else ! { ! gfc_expr *e2 = gfc_get_expr(); ! ! e2->expr_type = EXPR_OP; ! e2->ts = e->ts; ! e2->rank = e->rank; ! e2->where = where; ! e2->value.op.operator = INTRINSIC_PARENTHESES; ! e2->value.op.op1 = e; ! e2->value.op.op2 = NULL; ! *result = e2; ! } if (m != MATCH_YES) { --- 186,192 ---- if(!gfc_numeric_ts(&e->ts)) *result = e; else ! *result = gfc_get_parentheses (e); if (m != MATCH_YES) { diff -Nrcpad gcc-4.1.1/gcc/fortran/module.c gcc-4.1.2/gcc/fortran/module.c *** gcc-4.1.1/gcc/fortran/module.c Mon May 8 05:01:56 2006 --- gcc-4.1.2/gcc/fortran/module.c Mon Nov 6 17:18:03 2006 *************** gfc_use_module (void) *** 3772,3778 **** { char *filename; gfc_state_data *p; ! int c, line; filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION) + 1); --- 3772,3778 ---- { char *filename; gfc_state_data *p; ! int c, line, start; filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION) + 1); *************** gfc_use_module (void) *** 3787,3801 **** iomode = IO_INPUT; module_line = 1; module_column = 1; ! /* Skip the first two lines of the module. */ ! /* FIXME: Could also check for valid two lines here, instead. */ line = 0; while (line < 2) { c = module_char (); if (c == EOF) bad_module ("Unexpected end of module"); if (c == '\n') line++; } --- 3787,3809 ---- iomode = IO_INPUT; module_line = 1; module_column = 1; + start = 0; ! /* Skip the first two lines of the module, after checking that this is ! a gfortran module file. */ line = 0; while (line < 2) { c = module_char (); if (c == EOF) bad_module ("Unexpected end of module"); + if (start++ < 2) + parse_name (c); + if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0) + || (start == 2 && strcmp (atom_name, " module") != 0)) + gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module " + "file", filename); + if (c == '\n') line++; } diff -Nrcpad gcc-4.1.1/gcc/fortran/options.c gcc-4.1.2/gcc/fortran/options.c *** gcc-4.1.1/gcc/fortran/options.c Fri Apr 7 21:07:52 2006 --- gcc-4.1.2/gcc/fortran/options.c Wed Jun 28 05:36:08 2006 *************** gfc_init_options (unsigned int argc ATTR *** 71,76 **** --- 71,77 ---- gfc_option.flag_max_stack_var_size = 32768; gfc_option.flag_module_access_private = 0; gfc_option.flag_no_backend = 0; + gfc_option.flag_range_check = 1; gfc_option.flag_pack_derived = 0; gfc_option.flag_repack_arrays = 0; gfc_option.flag_preprocessed = 0; *************** gfc_handle_option (size_t scode, const c *** 497,502 **** --- 498,507 ---- gfc_option.flag_no_backend = value; break; + case OPT_frange_check: + gfc_option.flag_range_check = value; + break; + case OPT_fpack_derived: gfc_option.flag_pack_derived = value; break; diff -Nrcpad gcc-4.1.1/gcc/fortran/parse.c gcc-4.1.2/gcc/fortran/parse.c *** gcc-4.1.1/gcc/fortran/parse.c Wed May 17 12:04:17 2006 --- gcc-4.1.2/gcc/fortran/parse.c Wed Aug 30 05:19:34 2006 *************** parse_derived (void) *** 1254,1260 **** { int compiling_type, seen_private, seen_sequence, seen_component, error_flag; gfc_statement st; - gfc_component *c; gfc_state_data s; error_flag = 0; --- 1254,1259 ---- *************** parse_derived (void) *** 1352,1371 **** } } - /* Sanity checks on the structure. If the structure has the - SEQUENCE attribute, then all component structures must also have - SEQUENCE. */ - if (error_flag == 0 && gfc_current_block ()->attr.sequence) - for (c = gfc_current_block ()->components; c; c = c->next) - { - if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0) - { - gfc_error - ("Component %s of SEQUENCE type declared at %C does not " - "have the SEQUENCE attribute", c->ts.derived->name); - } - } - pop_state (); } --- 1351,1356 ---- *************** loop: *** 2060,2065 **** --- 2045,2059 ---- break; case ST_IMPLIED_ENDDO: + /* If the do-stmt of this DO construct has a do-construct-name, + the corresponding end-do must be an end-do-stmt (with a matching + name, but in that case we must have seen ST_ENDDO first). + We only complain about this in pedantic mode. */ + if (gfc_current_block () != NULL) + gfc_error_now + ("named block DO at %L requires matching ENDDO name", + &gfc_current_block()->declared_at); + break; default: *************** gfc_fixup_sibling_symbols (gfc_symbol * *** 2181,2188 **** for (ns = siblings; ns; ns = ns->sibling) { gfc_find_sym_tree (sym->name, ns, 0, &st); ! if (!st) ! continue; old_sym = st->n.sym; if ((old_sym->attr.flavor == FL_PROCEDURE --- 2175,2183 ---- for (ns = siblings; ns; ns = ns->sibling) { gfc_find_sym_tree (sym->name, ns, 0, &st); ! ! if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns)) ! continue; old_sym = st->n.sym; if ((old_sym->attr.flavor == FL_PROCEDURE diff -Nrcpad gcc-4.1.1/gcc/fortran/primary.c gcc-4.1.2/gcc/fortran/primary.c *** gcc-4.1.1/gcc/fortran/primary.c Sat Dec 31 18:55:30 2005 --- gcc-4.1.2/gcc/fortran/primary.c Sat Jan 27 17:14:06 2007 *************** match_hollerith_constant (gfc_expr ** re *** 283,288 **** --- 283,289 ---- gfc_default_character_kind, &gfc_current_locus); e->value.character.string = gfc_getmem (num+1); memcpy (e->value.character.string, buffer, num); + e->value.character.string[num] = '\0'; e->value.character.length = num; *result = e; return MATCH_YES; *************** next_string_char (char delimiter) *** 777,782 **** --- 778,786 ---- gfc_current_locus = old_locus; break; } + + if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) + gfc_warning ("Extension: backslash character at %C"); } if (c != delimiter) *************** gfc_match_rvalue (gfc_expr ** result) *** 1914,1919 **** --- 1918,1925 ---- gfc_expr *e; match m, m2; int i; + gfc_typespec *ts; + bool implicit_char; m = gfc_match_name (name); if (m != MATCH_YES) *************** gfc_match_rvalue (gfc_expr ** result) *** 1935,1940 **** --- 1941,1961 ---- if (sym->attr.function && sym->result == sym) { + /* See if this is a directly recursive function call. */ + gfc_gobble_whitespace (); + if (sym->attr.recursive + && gfc_peek_char () == '(' + && gfc_current_ns->proc_name == sym) + { + if (!sym->attr.dimension) + goto function0; + + gfc_error ("'%s' is array valued and directly recursive " + "at %C , so the keyword RESULT must be specified " + "in the FUNCTION statement", sym->name); + return MATCH_ERROR; + } + if (gfc_current_ns->proc_name == sym || (gfc_current_ns->parent != NULL && gfc_current_ns->parent->proc_name == sym)) *************** gfc_match_rvalue (gfc_expr ** result) *** 2143,2152 **** if (m2 != MATCH_YES) { /* See if this could possibly be a substring reference of a name that we're not sure is a variable yet. */ ! if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER) && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES) { --- 2164,2185 ---- if (m2 != MATCH_YES) { + /* Try to figure out whether we're dealing with a character type. + We're peeking ahead here, because we don't want to call + match_substring if we're dealing with an implicitly typed + non-character variable. */ + implicit_char = false; + if (sym->ts.type == BT_UNKNOWN) + { + ts = gfc_get_default_type (sym,NULL); + if (ts->type == BT_CHARACTER) + implicit_char = true; + } + /* See if this could possibly be a substring reference of a name that we're not sure is a variable yet. */ ! if ((implicit_char || sym->ts.type == BT_CHARACTER) && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES) { *************** match_variable (gfc_expr ** result, int *** 2268,2273 **** --- 2301,2310 ---- case FL_VARIABLE: break; + case FL_PROGRAM: + return MATCH_NO; + break; + case FL_UNKNOWN: if (gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL) == FAILURE) diff -Nrcpad gcc-4.1.1/gcc/fortran/resolve.c gcc-4.1.2/gcc/fortran/resolve.c *** gcc-4.1.1/gcc/fortran/resolve.c Thu May 11 21:39:06 2006 --- gcc-4.1.2/gcc/fortran/resolve.c Sun Feb 11 00:25:44 2007 *************** Software Foundation, 51 Franklin Street, *** 23,28 **** --- 23,29 ---- #include "config.h" #include "system.h" + #include "flags.h" #include "gfortran.h" #include "arith.h" /* For gfc_compare_expr(). */ *************** static int forall_flag; *** 55,60 **** --- 56,67 ---- resets the flag each time that it is read. */ static int formal_arg_flag = 0; + /* True if we are resolving a specification expression. */ + static int specification_expr = 0; + + /* The id of the last entry seen. */ + static int current_entry_id; + int gfc_is_formal_arg (void) { *************** resolve_formal_arglist (gfc_symbol * pro *** 220,226 **** { gfc_error ("Character-valued argument '%s' of statement function at " ! "%L must has constant length", sym->name, &sym->declared_at); continue; } --- 227,233 ---- { gfc_error ("Character-valued argument '%s' of statement function at " ! "%L must have constant length", sym->name, &sym->declared_at); continue; } *************** resolve_entries (gfc_namespace * ns) *** 369,374 **** --- 376,391 ---- ns->entries = el; ns->proc_name->attr.entry = 1; + /* If it is a module function, it needs to be in the right namespace + so that gfc_get_fake_result_decl can gather up the results. The + need for this arose in get_proc_name, where these beasts were + left in their own namespace, to keep prior references linked to + the entry declaration.*/ + if (ns->proc_name->attr.function + && ns->parent + && ns->parent->proc_name->attr.flavor == FL_MODULE) + el->sym->ns = ns; + /* Add an entry statement for it. */ c = gfc_get_code (); c->op = EXEC_ENTRY; *************** resolve_entries (gfc_namespace * ns) *** 392,414 **** { gfc_symbol *sym; gfc_typespec *ts, *fts; ! gfc_add_function (&proc->attr, proc->name, NULL); proc->result = proc; fts = &ns->entries->sym->result->ts; if (fts->type == BT_UNKNOWN) fts = gfc_get_default_type (ns->entries->sym->result, NULL); for (el = ns->entries->next; el; el = el->next) { ts = &el->sym->result->ts; if (ts->type == BT_UNKNOWN) ts = gfc_get_default_type (el->sym->result, NULL); if (! gfc_compare_types (ts, fts) || (el->sym->result->attr.dimension != ns->entries->sym->result->attr.dimension) || (el->sym->result->attr.pointer != ns->entries->sym->result->attr.pointer)) break; } if (el == NULL) --- 409,441 ---- { gfc_symbol *sym; gfc_typespec *ts, *fts; ! gfc_array_spec *as, *fas; gfc_add_function (&proc->attr, proc->name, NULL); proc->result = proc; + fas = ns->entries->sym->as; + fas = fas ? fas : ns->entries->sym->result->as; fts = &ns->entries->sym->result->ts; if (fts->type == BT_UNKNOWN) fts = gfc_get_default_type (ns->entries->sym->result, NULL); for (el = ns->entries->next; el; el = el->next) { ts = &el->sym->result->ts; + as = el->sym->as; + as = as ? as : el->sym->result->as; if (ts->type == BT_UNKNOWN) ts = gfc_get_default_type (el->sym->result, NULL); + if (! gfc_compare_types (ts, fts) || (el->sym->result->attr.dimension != ns->entries->sym->result->attr.dimension) || (el->sym->result->attr.pointer != ns->entries->sym->result->attr.pointer)) break; + + else if (as && fas && gfc_compare_array_spec (as, fas) == 0) + gfc_error ("Procedure %s at %L has entries with mismatched " + "array specifications", ns->entries->sym->name, + &ns->entries->sym->declared_at); } if (el == NULL) *************** resolve_structure_cons (gfc_expr * expr) *** 556,561 **** --- 583,589 ---- gfc_constructor *cons; gfc_component *comp; try t; + symbol_attribute a; t = SUCCESS; cons = expr->value.constructor; *************** resolve_structure_cons (gfc_expr * expr) *** 570,579 **** for (; comp; comp = comp->next, cons = cons->next) { if (! cons->expr) ! { ! t = FAILURE; ! continue; ! } if (gfc_resolve_expr (cons->expr) == FAILURE) { --- 598,604 ---- for (; comp; comp = comp->next, cons = cons->next) { if (! cons->expr) ! continue; if (gfc_resolve_expr (cons->expr) == FAILURE) { *************** resolve_structure_cons (gfc_expr * expr) *** 595,600 **** --- 620,638 ---- else t = gfc_convert_type (cons->expr, &comp->ts, 1); } + + if (!comp->pointer || cons->expr->expr_type == EXPR_NULL) + continue; + + a = gfc_expr_attr (cons->expr); + + if (!a.pointer && !a.target) + { + t = FAILURE; + gfc_error ("The element in the derived type constructor at %L, " + "for pointer component '%s' should be a POINTER or " + "a TARGET", &cons->expr->where, comp->name); + } } return t; *************** resolve_actual_arglist (gfc_actual_argli *** 803,808 **** --- 841,854 ---- || sym->attr.external) { + /* If a procedure is not already determined to be something else + check if it is intrinsic. */ + if (!sym->attr.intrinsic + && !(sym->attr.external || sym->attr.use_assoc + || sym->attr.if_source == IFSRC_IFBODY) + && gfc_intrinsic_name (sym->name, sym->attr.subroutine)) + sym->attr.intrinsic = 1; + if (sym->attr.proc == PROC_ST_FUNCTION) { gfc_error ("Statement function '%s' at %L is not allowed as an " *************** resolve_actual_arglist (gfc_actual_argli *** 823,828 **** --- 869,881 ---- &e->where); } + if (sym->attr.generic) + { + gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not " + "allowed as an actual argument at %L", sym->name, + &e->where); + } + /* If the symbol is the function that names the current (or parent) scope, then we really have a variable reference. */ *************** resolve_actual_arglist (gfc_actual_argli *** 875,880 **** --- 928,1076 ---- return SUCCESS; } + + /* Do the checks of the actual argument list that are specific to elemental + procedures. If called with c == NULL, we have a function, otherwise if + expr == NULL, we have a subroutine. */ + static try + resolve_elemental_actual (gfc_expr *expr, gfc_code *c) + { + gfc_actual_arglist *arg0; + gfc_actual_arglist *arg; + gfc_symbol *esym = NULL; + gfc_intrinsic_sym *isym = NULL; + gfc_expr *e = NULL; + gfc_intrinsic_arg *iformal = NULL; + gfc_formal_arglist *eformal = NULL; + bool formal_optional = false; + bool set_by_optional = false; + int i; + int rank = 0; + + /* Is this an elemental procedure? */ + if (expr && expr->value.function.actual != NULL) + { + if (expr->value.function.esym != NULL + && expr->value.function.esym->attr.elemental) + { + arg0 = expr->value.function.actual; + esym = expr->value.function.esym; + } + else if (expr->value.function.isym != NULL + && expr->value.function.isym->elemental) + { + arg0 = expr->value.function.actual; + isym = expr->value.function.isym; + } + else + return SUCCESS; + } + else if (c && c->ext.actual != NULL + && c->symtree->n.sym->attr.elemental) + { + arg0 = c->ext.actual; + esym = c->symtree->n.sym; + } + else + return SUCCESS; + + /* The rank of an elemental is the rank of its array argument(s). */ + for (arg = arg0; arg; arg = arg->next) + { + if (arg->expr != NULL && arg->expr->rank > 0) + { + rank = arg->expr->rank; + if (arg->expr->expr_type == EXPR_VARIABLE + && arg->expr->symtree->n.sym->attr.optional) + set_by_optional = true; + + /* Function specific; set the result rank and shape. */ + if (expr) + { + expr->rank = rank; + if (!expr->shape && arg->expr->shape) + { + expr->shape = gfc_get_shape (rank); + for (i = 0; i < rank; i++) + mpz_init_set (expr->shape[i], arg->expr->shape[i]); + } + } + break; + } + } + + /* If it is an array, it shall not be supplied as an actual argument + to an elemental procedure unless an array of the same rank is supplied + as an actual argument corresponding to a nonoptional dummy argument of + that elemental procedure(12.4.1.5). */ + formal_optional = false; + if (isym) + iformal = isym->formal; + else + eformal = esym->formal; + + for (arg = arg0; arg; arg = arg->next) + { + if (eformal) + { + if (eformal->sym && eformal->sym->attr.optional) + formal_optional = true; + eformal = eformal->next; + } + else if (isym && iformal) + { + if (iformal->optional) + formal_optional = true; + iformal = iformal->next; + } + else if (isym) + formal_optional = true; + + if (pedantic && arg->expr != NULL + && arg->expr->expr_type == EXPR_VARIABLE + && arg->expr->symtree->n.sym->attr.optional + && formal_optional + && arg->expr->rank + && (set_by_optional || arg->expr->rank != rank) + && !(isym && isym->generic_id == GFC_ISYM_CONVERSION)) + { + gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS " + "MISSING, it cannot be the actual argument of an " + "ELEMENTAL procedure unless there is a non-optional" + "argument with the same rank (12.4.1.5)", + arg->expr->symtree->n.sym->name, &arg->expr->where); + return FAILURE; + } + } + + for (arg = arg0; arg; arg = arg->next) + { + if (arg->expr == NULL || arg->expr->rank == 0) + continue; + + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + if (resolve_assumed_size_actual (arg->expr)) + return FAILURE; + + if (expr) + continue; + + /* Elemental subroutine array actual arguments must conform. */ + if (e != NULL) + { + if (gfc_check_conformance ("elemental subroutine", arg->expr, e) + == FAILURE) + return FAILURE; + } + else + e = arg->expr; + } + + return SUCCESS; + } + + /* This function does the checking of references to global procedures as defined in sections 18.1 and 14.1, respectively, of the Fortran 77 and 95 standards. It checks for a gsymbol for the name, making *************** generic: *** 979,985 **** if (!gfc_generic_intrinsic (expr->symtree->n.sym->name)) { ! gfc_error ("Generic function '%s' at %L is not an intrinsic function", expr->symtree->n.sym->name, &expr->where); return FAILURE; } --- 1175,1181 ---- if (!gfc_generic_intrinsic (expr->symtree->n.sym->name)) { ! gfc_error ("There is no specific function for the generic '%s' at %L", expr->symtree->n.sym->name, &expr->where); return FAILURE; } *************** resolve_function (gfc_expr * expr) *** 1185,1191 **** const char *name; try t; int temp; - int i; sym = NULL; if (expr->symtree) --- 1381,1386 ---- *************** resolve_function (gfc_expr * expr) *** 1212,1217 **** --- 1407,1413 ---- && sym->ts.cl && sym->ts.cl->length == NULL && !sym->attr.dummy + && expr->value.function.esym == NULL && !sym->attr.contained) { /* Internal procedures are taken care of in resolve_contained_fntype. */ *************** resolve_function (gfc_expr * expr) *** 1261,1299 **** temp = need_full_assumed_size; need_full_assumed_size = 0; ! if (expr->value.function.actual != NULL ! && ((expr->value.function.esym != NULL ! && expr->value.function.esym->attr.elemental) ! || (expr->value.function.isym != NULL ! && expr->value.function.isym->elemental))) ! { ! ! /* The rank of an elemental is the rank of its array argument(s). */ ! for (arg = expr->value.function.actual; arg; arg = arg->next) ! { ! if (arg->expr != NULL && arg->expr->rank > 0) ! { ! expr->rank = arg->expr->rank; ! if (!expr->shape && arg->expr->shape) ! { ! expr->shape = gfc_get_shape (expr->rank); ! for (i = 0; i < expr->rank; i++) ! mpz_init_set (expr->shape[i], arg->expr->shape[i]); ! } ! break; ! } ! } ! ! /* Being elemental, the last upper bound of an assumed size array ! argument must be present. */ ! for (arg = expr->value.function.actual; arg; arg = arg->next) ! { ! if (arg->expr != NULL ! && arg->expr->rank > 0 ! && resolve_assumed_size_actual (arg->expr)) ! return FAILURE; ! } ! } else if (expr->value.function.actual != NULL && expr->value.function.isym != NULL --- 1457,1464 ---- temp = need_full_assumed_size; need_full_assumed_size = 0; ! if (resolve_elemental_actual (expr, NULL) == FAILURE) ! return FAILURE; else if (expr->value.function.actual != NULL && expr->value.function.isym != NULL *************** resolve_function (gfc_expr * expr) *** 1329,1336 **** if (forall_flag) { gfc_error ! ("Function reference to '%s' at %L is inside a FORALL block", ! name, &expr->where); t = FAILURE; } else if (gfc_pure (NULL)) --- 1494,1502 ---- if (forall_flag) { gfc_error ! ("reference to non-PURE function '%s' at %L inside a " ! "FORALL %s", name, &expr->where, forall_flag == 2 ? ! "mask" : "block"); t = FAILURE; } else if (gfc_pure (NULL)) *************** resolve_function (gfc_expr * expr) *** 1341,1346 **** --- 1507,1536 ---- } } + /* Functions without the RECURSIVE attribution are not allowed to + * call themselves. */ + if (expr->value.function.esym && !expr->value.function.esym->attr.recursive) + { + gfc_symbol *esym, *proc; + esym = expr->value.function.esym; + proc = gfc_current_ns->proc_name; + if (esym == proc) + { + gfc_error ("Function '%s' at %L cannot call itself, as it is not " + "RECURSIVE", name, &expr->where); + t = FAILURE; + } + + if (esym->attr.entry && esym->ns->entries && proc->ns->entries + && esym->ns->entries->sym == proc->ns->entries->sym) + { + gfc_error ("Call to ENTRY '%s' at %L is recursive, but function " + "'%s' is not declared as RECURSIVE", + esym->name, &expr->where, esym->ns->entries->sym->name); + t = FAILURE; + } + } + /* Character lengths of use associated functions may contains references to symbols not referenced from the current program unit otherwise. Make sure those symbols are marked as referenced. */ *************** resolve_generic_s (gfc_code * c) *** 1406,1436 **** sym = c->symtree->n.sym; ! m = resolve_generic_s0 (c, sym); ! if (m == MATCH_YES) ! return SUCCESS; ! if (m == MATCH_ERROR) ! return FAILURE; ! ! if (sym->ns->parent != NULL) { gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); ! if (sym != NULL) ! { ! m = resolve_generic_s0 (c, sym); ! if (m == MATCH_YES) ! return SUCCESS; ! if (m == MATCH_ERROR) ! return FAILURE; ! } } /* Last ditch attempt. */ ! if (!gfc_generic_intrinsic (sym->name)) { gfc_error ! ("Generic subroutine '%s' at %L is not an intrinsic subroutine", sym->name, &c->loc); return FAILURE; } --- 1596,1626 ---- sym = c->symtree->n.sym; ! for (;;) { + m = resolve_generic_s0 (c, sym); + if (m == MATCH_YES) + return SUCCESS; + else if (m == MATCH_ERROR) + return FAILURE; + + generic: + if (sym->ns->parent == NULL) + break; gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); ! ! if (sym == NULL) ! break; ! if (!generic_sym (sym)) ! goto generic; } /* Last ditch attempt. */ ! sym = c->symtree->n.sym; if (!gfc_generic_intrinsic (sym->name)) { gfc_error ! ("There is no specific subroutine for the generic '%s' at %L", sym->name, &c->loc); return FAILURE; } *************** resolve_specific_s (gfc_code * c) *** 1500,1522 **** sym = c->symtree->n.sym; ! m = resolve_specific_s0 (c, sym); ! if (m == MATCH_YES) ! return SUCCESS; ! if (m == MATCH_ERROR) ! return FAILURE; ! ! gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); ! ! if (sym != NULL) { m = resolve_specific_s0 (c, sym); if (m == MATCH_YES) return SUCCESS; if (m == MATCH_ERROR) return FAILURE; } gfc_error ("Unable to resolve the specific subroutine '%s' at %L", sym->name, &c->loc); --- 1690,1713 ---- sym = c->symtree->n.sym; ! for (;;) { m = resolve_specific_s0 (c, sym); if (m == MATCH_YES) return SUCCESS; if (m == MATCH_ERROR) return FAILURE; + + if (sym->ns->parent == NULL) + break; + + gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); + + if (sym == NULL) + break; } + sym = c->symtree->n.sym; gfc_error ("Unable to resolve the specific subroutine '%s' at %L", sym->name, &c->loc); *************** resolve_call (gfc_code * c) *** 1587,1592 **** --- 1778,1807 ---- && !c->symtree->n.sym->attr.use_assoc) resolve_global_procedure (c->symtree->n.sym, &c->loc, 1); + /* Subroutines without the RECURSIVE attribution are not allowed to + * call themselves. */ + if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive) + { + gfc_symbol *csym, *proc; + csym = c->symtree->n.sym; + proc = gfc_current_ns->proc_name; + if (csym == proc) + { + gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not " + "RECURSIVE", csym->name, &c->loc); + t = FAILURE; + } + + if (csym->attr.entry && csym->ns->entries && proc->ns->entries + && csym->ns->entries->sym == proc->ns->entries->sym) + { + gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine " + "'%s' is not declared as RECURSIVE", + csym->name, &c->loc, csym->ns->entries->sym->name); + t = FAILURE; + } + } + /* Switch off assumed size checking and do this again for certain kinds of procedure, once the procedure itself is resolved. */ need_full_assumed_size++; *************** resolve_call (gfc_code * c) *** 1618,1652 **** gfc_internal_error ("resolve_subroutine(): bad function type"); } ! /* Some checks of elemental subroutines. */ ! if (c->ext.actual != NULL ! && c->symtree->n.sym->attr.elemental) ! { ! gfc_actual_arglist * a; ! gfc_expr * e; ! e = NULL; ! ! for (a = c->ext.actual; a; a = a->next) ! { ! if (a->expr == NULL || a->expr->rank == 0) ! continue; ! ! /* The last upper bound of an assumed size array argument must ! be present. */ ! if (resolve_assumed_size_actual (a->expr)) ! return FAILURE; ! ! /* Array actual arguments must conform. */ ! if (e != NULL) ! { ! if (gfc_check_conformance ("elemental subroutine", a->expr, e) ! == FAILURE) ! return FAILURE; ! } ! else ! e = a->expr; ! } ! } return t; } --- 1833,1841 ---- gfc_internal_error ("resolve_subroutine(): bad function type"); } ! /* Some checks of elemental subroutine actual arguments. */ ! if (resolve_elemental_actual (NULL, c) == FAILURE) ! return FAILURE; return t; } *************** compare_bound_int (gfc_expr * a, int b) *** 2011,2022 **** --- 2200,2285 ---- } + /* Compare an integer expression with a mpz_t. */ + + static comparison + compare_bound_mpz_t (gfc_expr * a, mpz_t b) + { + int i; + + if (a == NULL || a->expr_type != EXPR_CONSTANT) + return CMP_UNKNOWN; + + if (a->ts.type != BT_INTEGER) + gfc_internal_error ("compare_bound_int(): Bad expression"); + + i = mpz_cmp (a->value.integer, b); + + if (i < 0) + return CMP_LT; + if (i > 0) + return CMP_GT; + return CMP_EQ; + } + + + /* Compute the last value of a sequence given by a triplet. + Return 0 if it wasn't able to compute the last value, or if the + sequence if empty, and 1 otherwise. */ + + static int + compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end, + gfc_expr * stride, mpz_t last) + { + mpz_t rem; + + if (start == NULL || start->expr_type != EXPR_CONSTANT + || end == NULL || end->expr_type != EXPR_CONSTANT + || (stride != NULL && stride->expr_type != EXPR_CONSTANT)) + return 0; + + if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER + || (stride != NULL && stride->ts.type != BT_INTEGER)) + return 0; + + if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ) + { + if (compare_bound (start, end) == CMP_GT) + return 0; + mpz_set (last, end->value.integer); + return 1; + } + + if (compare_bound_int (stride, 0) == CMP_GT) + { + /* Stride is positive */ + if (mpz_cmp (start->value.integer, end->value.integer) > 0) + return 0; + } + else + { + /* Stride is negative */ + if (mpz_cmp (start->value.integer, end->value.integer) < 0) + return 0; + } + + mpz_init (rem); + mpz_sub (rem, end->value.integer, start->value.integer); + mpz_tdiv_r (rem, rem, stride->value.integer); + mpz_sub (last, end->value.integer, rem); + mpz_clear (rem); + + return 1; + } + + /* Compare a single dimension of an array reference to the array specification. */ static try check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as) { + mpz_t last_value; /* Given start, end and stride values, calculate the minimum and maximum referenced indexes. */ *************** check_dimension (int i, gfc_array_ref * *** 2041,2053 **** return FAILURE; } ! if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) ! goto bound; ! if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) goto bound; ! /* TODO: Possibly, we could warn about end[i] being out-of-bound although ! it is legal (see 6.2.2.3.1). */ break; --- 2304,2344 ---- return FAILURE; } ! #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i]) ! #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i]) ! ! if (compare_bound (AR_START, AR_END) == CMP_EQ ! && (compare_bound (AR_START, as->lower[i]) == CMP_LT ! || compare_bound (AR_START, as->upper[i]) == CMP_GT)) goto bound; ! if (((compare_bound_int (ar->stride[i], 0) == CMP_GT ! || ar->stride[i] == NULL) ! && compare_bound (AR_START, AR_END) != CMP_GT) ! || (compare_bound_int (ar->stride[i], 0) == CMP_LT ! && compare_bound (AR_START, AR_END) != CMP_LT)) ! { ! if (compare_bound (AR_START, as->lower[i]) == CMP_LT) ! goto bound; ! if (compare_bound (AR_START, as->upper[i]) == CMP_GT) ! goto bound; ! } ! ! mpz_init (last_value); ! if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i], ! last_value)) ! { ! if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT ! || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT) ! { ! mpz_clear (last_value); ! goto bound; ! } ! } ! mpz_clear (last_value); ! ! #undef AR_START ! #undef AR_END break; *************** find_array_spec (gfc_expr * e) *** 2196,2204 **** --- 2487,2497 ---- { gfc_array_spec *as; gfc_component *c; + gfc_symbol *derived; gfc_ref *ref; as = e->symtree->n.sym->as; + derived = NULL; for (ref = e->ref; ref; ref = ref->next) switch (ref->type) *************** find_array_spec (gfc_expr * e) *** 2212,2220 **** break; case REF_COMPONENT: ! for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next) if (c == ref->u.c.component) ! break; if (c == NULL) gfc_internal_error ("find_array_spec(): Component not found"); --- 2505,2523 ---- break; case REF_COMPONENT: ! if (derived == NULL) ! derived = e->symtree->n.sym->ts.derived; ! ! c = derived->components; ! ! for (; c; c = c->next) if (c == ref->u.c.component) ! { ! /* Track the sequence of component references. */ ! if (c->ts.type == BT_DERIVED) ! derived = c->ts.derived; ! break; ! } if (c == NULL) gfc_internal_error ("find_array_spec(): Component not found"); *************** static try *** 2243,2248 **** --- 2546,2552 ---- resolve_array_ref (gfc_array_ref * ar) { int i, check_scalar; + gfc_expr *e; for (i = 0; i < ar->dimen; i++) { *************** resolve_array_ref (gfc_array_ref * ar) *** 2255,2262 **** if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE) return FAILURE; if (ar->dimen_type[i] == DIMEN_UNKNOWN) ! switch (ar->start[i]->rank) { case 0: ar->dimen_type[i] = DIMEN_ELEMENT; --- 2559,2568 ---- if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE) return FAILURE; + e = ar->start[i]; + if (ar->dimen_type[i] == DIMEN_UNKNOWN) ! switch (e->rank) { case 0: ar->dimen_type[i] = DIMEN_ELEMENT; *************** resolve_array_ref (gfc_array_ref * ar) *** 2264,2274 **** case 1: ar->dimen_type[i] = DIMEN_VECTOR; break; default: gfc_error ("Array index at %L is an array of rank %d", ! &ar->c_where[i], ar->start[i]->rank); return FAILURE; } } --- 2570,2583 ---- case 1: ar->dimen_type[i] = DIMEN_VECTOR; + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->ts.type == BT_DERIVED) + ar->start[i] = gfc_get_parentheses (e); break; default: gfc_error ("Array index at %L is an array of rank %d", ! &ar->c_where[i], e->rank); return FAILURE; } } *************** resolve_substring (gfc_ref * ref) *** 2317,2323 **** return FAILURE; } ! if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT) { gfc_error ("Substring start index at %L is less than one", &ref->u.ss.start->where); --- 2626,2634 ---- return FAILURE; } ! if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT ! && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ ! || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) { gfc_error ("Substring start index at %L is less than one", &ref->u.ss.start->where); *************** resolve_substring (gfc_ref * ref) *** 2345,2353 **** } if (ref->u.ss.length != NULL ! && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT) { ! gfc_error ("Substring end index at %L is out of bounds", &ref->u.ss.start->where); return FAILURE; } --- 2656,2666 ---- } if (ref->u.ss.length != NULL ! && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT ! && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ ! || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) { ! gfc_error ("Substring end index at %L exceeds the string length", &ref->u.ss.start->where); return FAILURE; } *************** static try *** 2554,2566 **** resolve_variable (gfc_expr * e) { gfc_symbol *sym; ! if (e->ref && resolve_ref (e) == FAILURE) ! return FAILURE; if (e->symtree == NULL) return FAILURE; sym = e->symtree->n.sym; if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) { --- 2867,2882 ---- resolve_variable (gfc_expr * e) { gfc_symbol *sym; + try t; ! t = SUCCESS; if (e->symtree == NULL) return FAILURE; + if (e->ref && resolve_ref (e) == FAILURE) + return FAILURE; + sym = e->symtree->n.sym; if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) { *************** resolve_variable (gfc_expr * e) *** 2573,2579 **** else { /* Must be a simple variable reference. */ ! if (gfc_set_default_type (sym, 1, NULL) == FAILURE) return FAILURE; e->ts = sym->ts; } --- 2889,2895 ---- else { /* Must be a simple variable reference. */ ! if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE) return FAILURE; e->ts = sym->ts; } *************** resolve_variable (gfc_expr * e) *** 2581,2587 **** if (check_assumed_size_reference (sym, e)) return FAILURE; ! return SUCCESS; } --- 2897,2969 ---- if (check_assumed_size_reference (sym, e)) return FAILURE; ! /* Deal with forward references to entries during resolve_code, to ! satisfy, at least partially, 12.5.2.5. */ ! if (gfc_current_ns->entries ! && current_entry_id == sym->entry_id ! && cs_base ! && cs_base->current ! && cs_base->current->op != EXEC_ENTRY) ! { ! gfc_entry_list *entry; ! gfc_formal_arglist *formal; ! int n; ! bool seen; ! ! /* If the symbol is a dummy... */ ! if (sym->attr.dummy) ! { ! entry = gfc_current_ns->entries; ! seen = false; ! ! /* ...test if the symbol is a parameter of previous entries. */ ! for (; entry && entry->id <= current_entry_id; entry = entry->next) ! for (formal = entry->sym->formal; formal; formal = formal->next) ! { ! if (formal->sym && sym->name == formal->sym->name) ! seen = true; ! } ! ! /* If it has not been seen as a dummy, this is an error. */ ! if (!seen) ! { ! if (specification_expr) ! gfc_error ("Variable '%s',used in a specification expression, " ! "is referenced at %L before the ENTRY statement " ! "in which it is a parameter", ! sym->name, &cs_base->current->loc); ! else ! gfc_error ("Variable '%s' is used at %L before the ENTRY " ! "statement in which it is a parameter", ! sym->name, &cs_base->current->loc); ! t = FAILURE; ! } ! } ! ! /* Now do the same check on the specification expressions. */ ! specification_expr = 1; ! if (sym->ts.type == BT_CHARACTER ! && gfc_resolve_expr (sym->ts.cl->length) == FAILURE) ! t = FAILURE; ! ! if (sym->as) ! for (n = 0; n < sym->as->rank; n++) ! { ! specification_expr = 1; ! if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE) ! t = FAILURE; ! specification_expr = 1; ! if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE) ! t = FAILURE; ! } ! specification_expr = 0; ! ! if (t == SUCCESS) ! /* Update the symbol's entry level. */ ! sym->entry_id = current_entry_id + 1; ! } ! ! return t; } *************** gfc_resolve_expr (gfc_expr * e) *** 2635,2640 **** --- 3017,3027 ---- gfc_expand_constructor (e); } + /* This provides the opportunity for the length of constructors with character + valued function elements to propogate the string length to the expression. */ + if (e->ts.type == BT_CHARACTER) + gfc_resolve_character_array_constructor (e); + break; case EXPR_STRUCTURE: *************** resolve_allocate_expr (gfc_expr * e, gfc *** 2997,3003 **** { init_st = gfc_get_code (); init_st->loc = code->loc; ! init_st->op = EXEC_ASSIGN; init_st->expr = expr_to_initialize (e); init_st->expr2 = init_e; --- 3384,3390 ---- { init_st = gfc_get_code (); init_st->loc = code->loc; ! init_st->op = EXEC_INIT_ASSIGN; init_st->expr = expr_to_initialize (e); init_st->expr2 = init_e; *************** resolve_select (gfc_code * code) *** 3307,3312 **** --- 3694,3700 ---- gfc_expr *case_expr; gfc_case *cp, *default_case, *tail, *head; int seen_unreachable; + int seen_logical; int ncases; bt type; try t; *************** resolve_select (gfc_code * code) *** 3389,3394 **** --- 3777,3783 ---- default_case = NULL; head = tail = NULL; ncases = 0; + seen_logical = 0; for (body = code->block; body; body = body->block) { *************** resolve_select (gfc_code * code) *** 3441,3446 **** --- 3830,3850 ---- break; } + if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT) + { + int value; + value = cp->low->value.logical == 0 ? 2 : 1; + if (value & seen_logical) + { + gfc_error ("constant logical value in CASE statement " + "is repeated at %L", + &cp->low->where); + t = FAILURE; + break; + } + seen_logical |= value; + } + if (cp->low != NULL && cp->high != NULL && cp->low != cp->high && gfc_compare_expr (cp->low, cp->high) > 0) *************** resolve_blocks (gfc_code * b, gfc_namesp *** 4188,4194 **** static void resolve_code (gfc_code * code, gfc_namespace * ns) { ! int forall_save = 0; code_stack frame; gfc_alloc *a; try t; --- 4592,4598 ---- static void resolve_code (gfc_code * code, gfc_namespace * ns) { ! int forall_save; code_stack frame; gfc_alloc *a; try t; *************** resolve_code (gfc_code * code, gfc_names *** 4200,4219 **** for (; code; code = code->next) { frame.current = code; if (code->op == EXEC_FORALL) { - forall_save = forall_flag; forall_flag = 1; gfc_resolve_forall (code, ns, forall_save); } else resolve_blocks (code->block, ns); - if (code->op == EXEC_FORALL) - forall_flag = forall_save; - t = gfc_resolve_expr (code->expr); if (gfc_resolve_expr (code->expr2) == FAILURE) t = FAILURE; --- 4604,4623 ---- for (; code; code = code->next) { frame.current = code; + forall_save = forall_flag; if (code->op == EXEC_FORALL) { forall_flag = 1; gfc_resolve_forall (code, ns, forall_save); + forall_flag = 2; } else resolve_blocks (code->block, ns); t = gfc_resolve_expr (code->expr); + forall_flag = forall_save; + if (gfc_resolve_expr (code->expr2) == FAILURE) t = FAILURE; *************** resolve_code (gfc_code * code, gfc_names *** 4226,4232 **** --- 4630,4640 ---- case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: + break; + case EXEC_ENTRY: + /* Keep track of which entry we are up to. */ + current_entry_id = code->ext.entry->id; break; case EXEC_WHERE: *************** resolve_code (gfc_code * code, gfc_names *** 4249,4257 **** break; case EXEC_RETURN: ! if (code->expr != NULL && code->expr->ts.type != BT_INTEGER) ! gfc_error ("Alternate RETURN statement at %L requires an INTEGER " ! "return specifier", &code->expr->where); break; case EXEC_ASSIGN: --- 4657,4669 ---- break; case EXEC_RETURN: ! if (code->expr != NULL ! && (code->expr->ts.type != BT_INTEGER || code->expr->rank)) ! gfc_error ("Alternate RETURN statement at %L requires a SCALAR-" ! "INTEGER return specifier", &code->expr->where); ! break; ! ! case EXEC_INIT_ASSIGN: break; case EXEC_ASSIGN: *************** resolve_values (gfc_symbol * sym) *** 4477,4483 **** static try resolve_index_expr (gfc_expr * e) { - if (gfc_resolve_expr (e) == FAILURE) return FAILURE; --- 4889,4894 ---- *************** resolve_charlen (gfc_charlen *cl) *** 4500,4507 **** cl->resolved = 1; if (resolve_index_expr (cl->length) == FAILURE) ! return FAILURE; return SUCCESS; } --- 4911,4923 ---- cl->resolved = 1; + specification_expr = 1; + if (resolve_index_expr (cl->length) == FAILURE) ! { ! specification_expr = 0; ! return FAILURE; ! } return SUCCESS; } *************** is_non_constant_shape_array (gfc_symbol *** 4514,4520 **** --- 4930,4938 ---- { gfc_expr *e; int i; + bool not_constant; + not_constant = false; if (sym->as != NULL) { /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that *************** is_non_constant_shape_array (gfc_symbol *** 4525,4541 **** e = sym->as->lower[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) ! return true; e = sym->as->upper[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) ! return true; } } ! return false; } /* Resolution of common features of flavors variable and procedure. */ static try --- 4943,5028 ---- e = sym->as->lower[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) ! not_constant = true; e = sym->as->upper[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) ! not_constant = true; } } ! return not_constant; } + + /* Assign the default initializer to a derived type variable or result. */ + + static void + apply_default_init (gfc_symbol *sym) + { + gfc_expr *lval; + gfc_expr *init = NULL; + gfc_code *init_st; + gfc_namespace *ns = sym->ns; + + if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function) + return; + + if (sym->ts.type == BT_DERIVED && sym->ts.derived) + init = gfc_default_initializer (&sym->ts); + + if (init == NULL) + return; + + /* Search for the function namespace if this is a contained + function without an explicit result. */ + if (sym->attr.function && sym == sym->result + && sym->name != sym->ns->proc_name->name) + { + ns = ns->contained; + for (;ns; ns = ns->sibling) + if (strcmp (ns->proc_name->name, sym->name) == 0) + break; + } + + if (ns == NULL) + { + gfc_free_expr (init); + return; + } + + /* Build an l-value expression for the result. */ + lval = gfc_get_expr (); + lval->expr_type = EXPR_VARIABLE; + lval->where = sym->declared_at; + lval->ts = sym->ts; + lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); + + /* It will always be a full array. */ + lval->rank = sym->as ? sym->as->rank : 0; + if (lval->rank) + { + lval->ref = gfc_get_ref (); + lval->ref->type = REF_ARRAY; + lval->ref->u.ar.type = AR_FULL; + lval->ref->u.ar.dimen = lval->rank; + lval->ref->u.ar.where = sym->declared_at; + lval->ref->u.ar.as = sym->as; + } + + /* Add the code at scope entry. */ + init_st = gfc_get_code (); + init_st->next = ns->code; + ns->code = init_st; + + /* Assign the default initializer to the l-value. */ + init_st->loc = sym->declared_at; + init_st->op = EXEC_INIT_ASSIGN; + init_st->expr = lval; + init_st->expr2 = init; + } + + /* Resolution of common features of flavors variable and procedure. */ static try *************** resolve_fl_variable (gfc_symbol *sym, in *** 4585,4606 **** int i; gfc_expr *e; gfc_expr *constructor_expr; if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE) return FAILURE; ! /* The shape of a main program or module array needs to be constant. */ ! if (sym->ns->proc_name ! && (sym->ns->proc_name->attr.flavor == FL_MODULE ! || sym->ns->proc_name->attr.is_main_program) ! && !sym->attr.use_assoc && !sym->attr.allocatable && !sym->attr.pointer && is_non_constant_shape_array (sym)) { ! gfc_error ("The module or main program array '%s' at %L must " ! "have constant shape", sym->name, &sym->declared_at); ! return FAILURE; } if (sym->ts.type == BT_CHARACTER) --- 5072,5105 ---- int i; gfc_expr *e; gfc_expr *constructor_expr; + const char * auto_save_msg; + + auto_save_msg = "automatic object '%s' at %L cannot have the " + "SAVE attribute"; if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE) return FAILURE; ! /* Set this flag to check that variables are parameters of all entries. ! This check is effected by the call to gfc_resolve_expr through ! is_non_constant_shape_array. */ ! specification_expr = 1; ! ! if (!sym->attr.use_assoc && !sym->attr.allocatable && !sym->attr.pointer && is_non_constant_shape_array (sym)) { ! /* The shape of a main program or module array needs to be constant. */ ! if (sym->ns->proc_name ! && (sym->ns->proc_name->attr.flavor == FL_MODULE ! || sym->ns->proc_name->attr.is_main_program)) ! { ! gfc_error ("The module or main program array '%s' at %L must " ! "have constant shape", sym->name, &sym->declared_at); ! specification_expr = 0; ! return FAILURE; ! } } if (sym->ts.type == BT_CHARACTER) *************** resolve_fl_variable (gfc_symbol *sym, in *** 4615,4620 **** --- 5114,5125 ---- return FAILURE; } + if (e && sym->attr.save && !gfc_is_constant_expr (e)) + { + gfc_error (auto_save_msg, sym->name, &sym->declared_at); + return FAILURE; + } + if (!gfc_is_constant_expr (e) && !(e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.flavor == FL_PARAMETER) *************** resolve_fl_variable (gfc_symbol *sym, in *** 4648,4653 **** --- 5153,5165 ---- break; } } + + /* Also, they must not have the SAVE attribute. */ + if (flag && sym->attr.save) + { + gfc_error (auto_save_msg, sym->name, &sym->declared_at); + return FAILURE; + } } /* Reject illegal initializers. */ *************** resolve_fl_variable (gfc_symbol *sym, in *** 4674,4679 **** --- 5186,5209 ---- return FAILURE; } + /* Check to see if a derived type is blocked from being host associated + by the presence of another class I symbol in the same namespace. + 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */ + if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns) + { + gfc_symbol *s; + gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s); + if (s && (s->attr.flavor != FL_DERIVED + || !gfc_compare_derived_types (s, sym->ts.derived))) + { + gfc_error ("The type %s cannot be host associated at %L because " + "it is blocked by an incompatible object of the same " + "name at %L", sym->ts.derived->name, &sym->declared_at, + &s->declared_at); + return FAILURE; + } + } + /* 4th constraint in section 11.3: "If an object of a type for which component-initialization is specified (R429) appears in the specification-part of a module and does not have the ALLOCATABLE *************** resolve_fl_variable (gfc_symbol *sym, in *** 4696,4703 **** } /* Assign default initializer. */ ! if (sym->ts.type == BT_DERIVED && !(sym->value || flag) ! && !sym->attr.pointer) sym->value = gfc_default_initializer (&sym->ts); return SUCCESS; --- 5226,5233 ---- } /* Assign default initializer. */ ! if (sym->ts.type == BT_DERIVED && !sym->value && !sym->attr.pointer ! && !sym->attr.allocatable && (!flag || sym->attr.intent == INTENT_OUT)) sym->value = gfc_default_initializer (&sym->ts); return SUCCESS; *************** resolve_fl_procedure (gfc_symbol *sym, i *** 4765,4770 **** --- 5295,5310 ---- return FAILURE; } + /* An elemental function is required to return a scalar 12.7.1 */ + if (sym->attr.elemental && sym->attr.function && sym->as) + { + gfc_error ("ELEMENTAL function '%s' at %L must have a scalar " + "result", sym->name, &sym->declared_at); + /* Reset so that the error only occurs once. */ + sym->attr.elemental = 0; + return FAILURE; + } + /* 5.1.1.5 of the Standard: A function name declared with an asterisk char-len-param shall not be array-valued, pointer-valued, recursive or pure. ....snip... A character value of * may only be used in the *************** resolve_fl_derived (gfc_symbol *sym) *** 4846,4851 **** --- 5386,5411 ---- return FAILURE; } + if (sym->attr.sequence) + { + if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0) + { + gfc_error ("Component %s of SEQUENCE type declared at %L does " + "not have the SEQUENCE attribute", + c->ts.derived->name, &sym->declared_at); + return FAILURE; + } + } + + if (c->ts.type == BT_DERIVED && c->pointer + && c->ts.derived->components == NULL) + { + gfc_error ("The pointer component '%s' of '%s' at %L is a type " + "that has not been declared", c->name, sym->name, + &c->loc); + return FAILURE; + } + if (c->pointer || c->as == NULL) continue; *************** resolve_fl_derived (gfc_symbol *sym) *** 4867,4876 **** } /* Add derived type to the derived type list. */ ! dt_list = gfc_get_dt_list (); ! dt_list->next = sym->ns->derived_types; ! dt_list->derived = sym; ! sym->ns->derived_types = dt_list; return SUCCESS; } --- 5427,5443 ---- } /* Add derived type to the derived type list. */ ! for (dt_list = sym->ns->derived_types; dt_list; dt_list = dt_list->next) ! if (sym == dt_list->derived) ! break; ! ! if (dt_list == NULL) ! { ! dt_list = gfc_get_dt_list (); ! dt_list->next = sym->ns->derived_types; ! dt_list->derived = sym; ! sym->ns->derived_types = dt_list; ! } return SUCCESS; } *************** resolve_fl_namelist (gfc_symbol *sym) *** 4918,4933 **** same message has been used. */ for (nl = sym->namelist; nl; nl = nl->next) { nlsym = NULL; ! if (sym->ns->parent && nl->sym && nl->sym->name) ! gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym); ! if (nlsym && nlsym->attr.flavor == FL_PROCEDURE) ! { ! gfc_error ("PROCEDURE attribute conflicts with NAMELIST " ! "attribute in '%s' at %L", nlsym->name, ! &sym->declared_at); ! return FAILURE; ! } } return SUCCESS; --- 5485,5502 ---- same message has been used. */ for (nl = sym->namelist; nl; nl = nl->next) { + if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE) + continue; nlsym = NULL; ! if (sym->ns->parent && nl->sym && nl->sym->name) ! gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym); ! if (nlsym && nlsym->attr.flavor == FL_PROCEDURE) ! { ! gfc_error ("PROCEDURE attribute conflicts with NAMELIST " ! "attribute in '%s' at %L", nlsym->name, ! &sym->declared_at); ! return FAILURE; ! } } return SUCCESS; *************** resolve_symbol (gfc_symbol * sym) *** 5142,5152 **** case FL_PARAMETER: if (resolve_fl_parameter (sym) == FAILURE) return; - break; default: - break; } --- 5711,5719 ---- *************** resolve_symbol (gfc_symbol * sym) *** 5171,5176 **** --- 5738,5762 ---- gfc_resolve (sym->formal_ns); formal_ns_flag = formal_ns_save; } + + /* If we have come this far we can apply default-initializers, as + described in 14.7.5, to those variables that have not already + been assigned one. */ + if (sym->ts.type == BT_DERIVED + && sym->attr.referenced + && sym->ns == gfc_current_ns + && !sym->value + && !sym->attr.allocatable) + { + symbol_attribute *a = &sym->attr; + + if ((!a->save && !a->dummy && !a->pointer + && !a->in_common && !a->use_assoc + && !(a->function && sym != sym->result)) + || + (a->dummy && a->intent == INTENT_OUT)) + apply_default_init (sym); + } } *************** gfc_elemental (gfc_symbol * sym) *** 5547,5553 **** /* Warn about unused labels. */ static void ! warn_unused_label (gfc_namespace * ns) { gfc_st_label *l; --- 6133,6139 ---- /* Warn about unused labels. */ static void ! warn_unused_fortran_label (gfc_namespace * ns) { gfc_st_label *l; *************** resolve_equivalence (gfc_equiv *eq) *** 5795,5801 **** { if (value_name != NULL) { ! gfc_error ("Initialized objects '%s' and '%s' cannot both " "be in the EQUIVALENCE statement at %L", value_name, sym->name, &e->where); continue; --- 6381,6387 ---- { if (value_name != NULL) { ! gfc_error ("Initialized objects '%s' and '%s' cannot both " "be in the EQUIVALENCE statement at %L", value_name, sym->name, &e->where); continue; *************** resolve_fntype (gfc_namespace * ns) *** 5966,5971 **** --- 6552,6572 ---- sym->name, &sym->declared_at, sym->ts.derived->name); } + /* Make sure that the type of a module derived type function is in the + module namespace, by copying it from the namespace's derived type + list, if necessary. */ + if (sym->ts.type == BT_DERIVED + && sym->ns->proc_name->attr.flavor == FL_MODULE + && sym->ts.derived->ns + && sym->ns != sym->ts.derived->ns) + { + gfc_dt_list *dt = sym->ns->derived_types; + + for (; dt; dt = dt->next) + if (gfc_compare_derived_types (sym->ts.derived, dt->derived)) + sym->ts.derived = dt->derived; + } + if (ns->entries) for (el = ns->entries->next; el; el = el->next) { *************** resolve_types (gfc_namespace * ns) *** 6101,6107 **** /* Warn about unused labels. */ if (gfc_option.warn_unused_labels) ! warn_unused_label (ns); gfc_resolve_uops (ns->uop_root); } --- 6702,6708 ---- /* Warn about unused labels. */ if (gfc_option.warn_unused_labels) ! warn_unused_fortran_label (ns); gfc_resolve_uops (ns->uop_root); } *************** resolve_codes (gfc_namespace * ns) *** 6119,6124 **** --- 6720,6727 ---- gfc_current_ns = ns; cs_base = NULL; + /* Set to an out of range value. */ + current_entry_id = -1; resolve_code (ns->code, ns); } diff -Nrcpad gcc-4.1.1/gcc/fortran/simplify.c gcc-4.1.2/gcc/fortran/simplify.c *** gcc-4.1.1/gcc/fortran/simplify.c Fri May 5 09:00:25 2006 --- gcc-4.1.2/gcc/fortran/simplify.c Fri Nov 24 22:45:21 2006 *************** static int xascii_table[256]; *** 95,104 **** static gfc_expr * range_check (gfc_expr * result, const char *name) { - if (gfc_range_check (result) == ARITH_OK) - return result; ! gfc_error ("Result of %s overflows its kind at %L", name, &result->where); gfc_free_expr (result); return &gfc_bad_expr; } --- 95,123 ---- static gfc_expr * range_check (gfc_expr * result, const char *name) { ! switch (gfc_range_check (result)) ! { ! case ARITH_OK: ! return result; ! ! case ARITH_OVERFLOW: ! gfc_error ("Result of %s overflows its kind at %L", name, &result->where); ! break; ! ! case ARITH_UNDERFLOW: ! gfc_error ("Result of %s underflows its kind at %L", name, &result->where); ! break; ! ! case ARITH_NAN: ! gfc_error ("Result of %s is NaN at %L", name, &result->where); ! break; ! ! default: ! gfc_error ("Result of %s gives range error for its kind at %L", name, &result->where); ! break; ! } ! gfc_free_expr (result); return &gfc_bad_expr; } *************** simplify_bound (gfc_expr * array, gfc_ex *** 1847,1858 **** { gfc_ref *ref; gfc_array_spec *as; ! gfc_expr *e; int d; - if (array->expr_type != EXPR_VARIABLE) - return NULL; - if (dim == NULL) /* TODO: Simplify constant multi-dimensional bounds. */ return NULL; --- 1866,1874 ---- { gfc_ref *ref; gfc_array_spec *as; ! gfc_expr *l, *u, *result; int d; if (dim == NULL) /* TODO: Simplify constant multi-dimensional bounds. */ return NULL; *************** simplify_bound (gfc_expr * array, gfc_ex *** 1860,1865 **** --- 1876,1884 ---- if (dim->expr_type != EXPR_CONSTANT) return NULL; + if (array->expr_type != EXPR_VARIABLE) + return NULL; + /* Follow any component references. */ as = array->symtree->n.sym->as; for (ref = array->ref; ref; ref = ref->next) *************** simplify_bound (gfc_expr * array, gfc_ex *** 1909,1920 **** return &gfc_bad_expr; } ! e = upper ? as->upper[d-1] : as->lower[d-1]; ! if (e->expr_type != EXPR_CONSTANT) return NULL; ! return gfc_copy_expr (e); } --- 1928,1970 ---- return &gfc_bad_expr; } ! /* The last dimension of an assumed-size array is special. */ ! if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) ! { ! if (as->lower[d-1]->expr_type == EXPR_CONSTANT) ! return gfc_copy_expr (as->lower[d-1]); ! else ! return NULL; ! } ! /* Then, we need to know the extent of the given dimension. */ ! l = as->lower[d-1]; ! u = as->upper[d-1]; ! ! if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT) return NULL; ! result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, ! &array->where); ! ! if (mpz_cmp (l->value.integer, u->value.integer) > 0) ! { ! /* Zero extent. */ ! if (upper) ! mpz_set_si (result->value.integer, 0); ! else ! mpz_set_si (result->value.integer, 1); ! } ! else ! { ! /* Nonzero extent. */ ! if (upper) ! mpz_set (result->value.integer, u->value.integer); ! else ! mpz_set (result->value.integer, l->value.integer); ! } ! ! return range_check (result, upper ? "UBOUND" : "LBOUND"); } *************** gfc_simplify_rrspacing (gfc_expr * x) *** 3011,3016 **** --- 3061,3067 ---- mpfr_init (absv); mpfr_init (frac); mpfr_init (pow2); + mpfr_init (exp); mpfr_abs (absv, x->value.real, GFC_RND_MODE); mpfr_log2 (log2, absv, GFC_RND_MODE); *************** gfc_simplify_rrspacing (gfc_expr * x) *** 3027,3032 **** --- 3078,3084 ---- mpfr_clear (absv); mpfr_clear (frac); mpfr_clear (pow2); + mpfr_clear (exp); return range_check (result, "RRSPACING"); } *************** gfc_simplify_tiny (gfc_expr * e) *** 3696,3701 **** --- 3748,3766 ---- gfc_expr * + gfc_simplify_transfer (gfc_expr * source, gfc_expr *mold, gfc_expr * size) + { + + /* Reference mold and size to suppress warning. */ + if (gfc_init_expr && (mold || size)) + gfc_error ("TRANSFER intrinsic not implemented for initialization at %L", + &source->where); + + return NULL; + } + + + gfc_expr * gfc_simplify_trim (gfc_expr * e) { gfc_expr *result; diff -Nrcpad gcc-4.1.1/gcc/fortran/st.c gcc-4.1.2/gcc/fortran/st.c *** gcc-4.1.1/gcc/fortran/st.c Sun Aug 7 22:56:19 2005 --- gcc-4.1.2/gcc/fortran/st.c Fri Nov 10 21:52:00 2006 *************** gfc_free_statement (gfc_code * p) *** 92,97 **** --- 92,98 ---- { case EXEC_NOP: case EXEC_ASSIGN: + case EXEC_INIT_ASSIGN: case EXEC_GOTO: case EXEC_CYCLE: case EXEC_RETURN: *************** gfc_free_statement (gfc_code * p) *** 111,116 **** --- 112,118 ---- break; case EXEC_CALL: + case EXEC_ASSIGN_CALL: gfc_free_actual_arglist (p->ext.actual); break; diff -Nrcpad gcc-4.1.1/gcc/fortran/symbol.c gcc-4.1.2/gcc/fortran/symbol.c *** gcc-4.1.1/gcc/fortran/symbol.c Tue Mar 7 00:06:37 2006 --- gcc-4.1.2/gcc/fortran/symbol.c Tue Sep 5 04:29:56 2006 *************** Software Foundation, 51 Franklin Street, *** 23,28 **** --- 23,29 ---- #include "config.h" #include "system.h" + #include "flags.h" #include "gfortran.h" #include "parse.h" *************** gfc_add_type (gfc_symbol * sym, gfc_type *** 1130,1138 **** if (sym->ts.type != BT_UNKNOWN) { ! gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name, ! where, gfc_basic_typename (sym->ts.type)); ! return FAILURE; } flavor = sym->attr.flavor; --- 1131,1148 ---- if (sym->ts.type != BT_UNKNOWN) { ! const char *msg = "Symbol '%s' at %L already has basic type of %s"; ! if (!(sym->ts.type == ts->type ! && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result)) ! || gfc_notification_std (GFC_STD_GNU) == ERROR ! || pedantic) ! { ! gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type)); ! return FAILURE; ! } ! else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where, ! gfc_basic_typename (sym->ts.type)) == FAILURE) ! return FAILURE; } flavor = sym->attr.flavor; diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-array.c gcc-4.1.2/gcc/fortran/trans-array.c *** gcc-4.1.1/gcc/fortran/trans-array.c Mon May 8 05:01:56 2006 --- gcc-4.1.2/gcc/fortran/trans-array.c Wed Dec 13 22:37:21 2006 *************** gfc_trans_allocate_array_storage (stmtbl *** 570,582 **** tree gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_loopinfo * loop, gfc_ss_info * info, ! tree eltype, bool dynamic, bool dealloc) { tree type; tree desc; tree tmp; tree size; tree nelem; int n; int dim; --- 570,590 ---- tree gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_loopinfo * loop, gfc_ss_info * info, ! tree eltype, bool dynamic, bool dealloc, ! bool function) { tree type; tree desc; tree tmp; tree size; tree nelem; + tree cond; + tree or_expr; + tree thencase; + tree elsecase; + tree var; + stmtblock_t thenblock; + stmtblock_t elseblock; int n; int dim; *************** gfc_trans_allocate_temp_array (stmtblock *** 628,633 **** --- 636,643 ---- size = size * sizeof(element); */ + or_expr = NULL_TREE; + for (n = 0; n < info->dimen; n++) { if (loop->to[n] == NULL_TREE) *************** gfc_trans_allocate_temp_array (stmtblock *** 655,670 **** tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, loop->to[n], gfc_index_one_node); size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); size = gfc_evaluate_now (size, pre); } /* Get the size of the array. */ ! nelem = size; if (size) ! size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, ! TYPE_SIZE_UNIT (gfc_get_element_type (type))); gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic, dealloc); --- 665,721 ---- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, loop->to[n], gfc_index_one_node); + if (function) + { + /* Check wether the size for this dimension is negative. */ + cond = fold_build2 (LE_EXPR, boolean_type_node, tmp, + gfc_index_zero_node); + + cond = gfc_evaluate_now (cond, pre); + + if (n == 0) + or_expr = cond; + else + or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond); + } + size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); size = gfc_evaluate_now (size, pre); } /* Get the size of the array. */ ! if (size) ! { ! if (function) ! { ! var = gfc_create_var (TREE_TYPE (size), "size"); ! gfc_start_block (&thenblock); ! gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node); ! thencase = gfc_finish_block (&thenblock); ! ! gfc_start_block (&elseblock); ! gfc_add_modify_expr (&elseblock, var, size); ! elsecase = gfc_finish_block (&elseblock); ! ! tmp = gfc_evaluate_now (or_expr, pre); ! tmp = build3_v (COND_EXPR, tmp, thencase, elsecase); ! gfc_add_expr_to_block (pre, tmp); ! nelem = var; ! size = var; ! } ! else ! nelem = size; + size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + } + else + { + nelem = size; + size = NULL_TREE; + } + gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic, dealloc); *************** get_array_ctor_var_strlen (gfc_expr * ex *** 1201,1206 **** --- 1252,1258 ---- { gfc_ref *ref; gfc_typespec *ts; + mpz_t char_len; /* Don't bother if we already know the length is a constant. */ if (*len && INTEGER_CST_P (*len)) *************** get_array_ctor_var_strlen (gfc_expr * ex *** 1220,1225 **** --- 1272,1290 ---- ts = &ref->u.c.component->ts; break; + case REF_SUBSTRING: + if (ref->u.ss.start->expr_type != EXPR_CONSTANT + || ref->u.ss.start->expr_type != EXPR_CONSTANT) + break; + mpz_init_set_ui (char_len, 1); + mpz_add (char_len, char_len, ref->u.ss.end->value.integer); + mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); + *len = gfc_conv_mpz_to_tree (char_len, + gfc_default_character_kind); + *len = convert (gfc_charlen_type_node, *len); + mpz_clear (char_len); + return; + default: /* TODO: Substrings are tricky because we can't evaluate the expression more than once. For now we just give up, and hope *************** gfc_trans_array_constructor (gfc_loopinf *** 1328,1334 **** } gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop, ! &ss->data.info, type, dynamic, true); desc = ss->data.info.descriptor; offset = gfc_index_zero_node; --- 1393,1399 ---- } gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop, ! &ss->data.info, type, dynamic, true, false); desc = ss->data.info.descriptor; offset = gfc_index_zero_node; *************** gfc_conv_array_ubound (tree descriptor, *** 1672,1696 **** /* Generate code to perform an array index bound check. */ static tree ! gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n) { - tree cond; tree fault; tree tmp; if (!flag_bounds_check) return index; index = gfc_evaluate_now (index, &se->pre); /* Check lower bound. */ tmp = gfc_conv_array_lbound (descriptor, n); fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp); /* Check upper bound. */ tmp = gfc_conv_array_ubound (descriptor, n); ! cond = fold_build2 (GT_EXPR, boolean_type_node, index, tmp); ! fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond); ! ! gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre); return index; } --- 1737,1777 ---- /* Generate code to perform an array index bound check. */ static tree ! gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, ! locus * where) { tree fault; tree tmp; + char *msg; if (!flag_bounds_check) return index; index = gfc_evaluate_now (index, &se->pre); + /* Check lower bound. */ tmp = gfc_conv_array_lbound (descriptor, n); fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp); + if (se->ss) + asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded", + gfc_msg_fault, se->ss->expr->symtree->name, n+1); + else + asprintf (&msg, "%s, lower bound of dimension %d exceeded", + gfc_msg_fault, n+1); + gfc_trans_runtime_check (fault, msg, &se->pre, where); + gfc_free (msg); + /* Check upper bound. */ tmp = gfc_conv_array_ubound (descriptor, n); ! fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp); ! if (se->ss) ! asprintf (&msg, "%s for array '%s', upper bound of dimension %d exceeded", ! gfc_msg_fault, se->ss->expr->symtree->name, n+1); ! else ! asprintf (&msg, "%s, upper bound of dimension %d exceeded", ! gfc_msg_fault, n+1); ! gfc_trans_runtime_check (fault, msg, &se->pre, where); ! gfc_free (msg); return index; } *************** gfc_conv_array_index_offset (gfc_se * se *** 1721,1728 **** /* We've already translated this value outside the loop. */ index = info->subscript[dim]->data.scalar.expr; ! index = ! gfc_trans_array_bound_check (se, info->descriptor, index, dim); break; case DIMEN_VECTOR: --- 1802,1811 ---- /* We've already translated this value outside the loop. */ index = info->subscript[dim]->data.scalar.expr; ! if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed) ! || dim < ar->dimen - 1) ! index = gfc_trans_array_bound_check (se, info->descriptor, ! index, dim, &ar->where); break; case DIMEN_VECTOR: *************** gfc_conv_array_index_offset (gfc_se * se *** 1745,1752 **** index = gfc_evaluate_now (index, &se->pre); /* Do any bounds checking on the final info->descriptor index. */ ! index = gfc_trans_array_bound_check (se, info->descriptor, ! index, dim); break; case DIMEN_RANGE: --- 1828,1837 ---- index = gfc_evaluate_now (index, &se->pre); /* Do any bounds checking on the final info->descriptor index. */ ! if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed) ! || dim < ar->dimen - 1) ! index = gfc_trans_array_bound_check (se, info->descriptor, ! index, dim, &ar->where); break; case DIMEN_RANGE: *************** gfc_conv_tmp_array_ref (gfc_se * se) *** 1826,1838 **** a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/ void ! gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar) { int n; tree index; tree tmp; tree stride; - tree fault; gfc_se indexse; /* Handle scalarized references separately. */ --- 1911,1923 ---- a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/ void ! gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, ! locus * where) { int n; tree index; tree tmp; tree stride; gfc_se indexse; /* Handle scalarized references separately. */ *************** gfc_conv_array_ref (gfc_se * se, gfc_arr *** 1845,1852 **** index = gfc_index_zero_node; - fault = gfc_index_zero_node; - /* Calculate the offsets from all the dimensions. */ for (n = 0; n < ar->dimen; n++) { --- 1930,1935 ---- *************** gfc_conv_array_ref (gfc_se * se, gfc_arr *** 1855,1878 **** gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type); gfc_add_block_to_block (&se->pre, &indexse.pre); ! if (flag_bounds_check) { /* Check array bounds. */ tree cond; indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre); tmp = gfc_conv_array_lbound (se->expr, n); cond = fold_build2 (LT_EXPR, boolean_type_node, indexse.expr, tmp); ! fault = ! fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond); tmp = gfc_conv_array_ubound (se->expr, n); cond = fold_build2 (GT_EXPR, boolean_type_node, indexse.expr, tmp); ! fault = ! fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond); } /* Multiply the index by the stride. */ --- 1938,1970 ---- gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type); gfc_add_block_to_block (&se->pre, &indexse.pre); ! if (flag_bounds_check && ! ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed) ! || n < ar->dimen - 1)) { /* Check array bounds. */ tree cond; + char *msg; indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre); tmp = gfc_conv_array_lbound (se->expr, n); cond = fold_build2 (LT_EXPR, boolean_type_node, indexse.expr, tmp); ! asprintf (&msg, "%s for array '%s', " ! "lower bound of dimension %d exceeded", gfc_msg_fault, ! sym->name, n+1); ! gfc_trans_runtime_check (cond, msg, &se->pre, where); ! gfc_free (msg); tmp = gfc_conv_array_ubound (se->expr, n); cond = fold_build2 (GT_EXPR, boolean_type_node, indexse.expr, tmp); ! asprintf (&msg, "%s for array '%s', " ! "upper bound of dimension %d exceeded", gfc_msg_fault, ! sym->name, n+1); ! gfc_trans_runtime_check (cond, msg, &se->pre, where); ! gfc_free (msg); } /* Multiply the index by the stride. */ *************** gfc_conv_array_ref (gfc_se * se, gfc_arr *** 1884,1892 **** index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp); } - if (flag_bounds_check) - gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre); - tmp = gfc_conv_array_offset (se->expr); if (!integer_zerop (tmp)) index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp); --- 1976,1981 ---- *************** gfc_conv_ss_startstride (gfc_loopinfo * *** 2363,2378 **** if (flag_bounds_check) { stmtblock_t block; ! tree fault; ! tree bound; tree end; tree size[GFC_MAX_DIMENSIONS]; gfc_ss_info *info; int dim; gfc_start_block (&block); - fault = integer_zero_node; for (n = 0; n < loop->dimen; n++) size[n] = NULL_TREE; --- 2452,2467 ---- if (flag_bounds_check) { stmtblock_t block; ! tree lbound, ubound; tree end; tree size[GFC_MAX_DIMENSIONS]; + tree stride_pos, stride_neg, non_zerosized, tmp2; gfc_ss_info *info; + char *msg; int dim; gfc_start_block (&block); for (n = 0; n < loop->dimen; n++) size[n] = NULL_TREE; *************** gfc_conv_ss_startstride (gfc_loopinfo * *** 2391,2412 **** dim = info->dim[n]; if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) continue; desc = ss->data.info.descriptor; ! /* Check lower bound. */ ! bound = gfc_conv_array_lbound (desc, dim); ! tmp = info->start[n]; ! tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp, bound); ! fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, ! tmp); ! ! /* Check the upper bound. */ ! bound = gfc_conv_array_ubound (desc, dim); end = gfc_conv_section_upper_bound (ss, n, &block); ! tmp = fold_build2 (GT_EXPR, boolean_type_node, end, bound); ! fault = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, fault, ! tmp); /* Check the section sizes match. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, --- 2480,2575 ---- dim = info->dim[n]; if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) continue; + if (n == info->ref->u.ar.dimen - 1 + && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE + || info->ref->u.ar.as->cp_was_assumed)) + continue; desc = ss->data.info.descriptor; ! /* This is the run-time equivalent of resolve.c's ! check_dimension(). The logical is more readable there ! than it is here, with all the trees. */ ! lbound = gfc_conv_array_lbound (desc, dim); ! ubound = gfc_conv_array_ubound (desc, dim); end = gfc_conv_section_upper_bound (ss, n, &block); ! ! /* Zero stride is not allowed. */ ! tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n], ! gfc_index_zero_node); ! asprintf (&msg, "Zero stride is not allowed, for dimension %d " ! "of array '%s'", info->dim[n]+1, ! ss->expr->symtree->name); ! gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where); ! gfc_free (msg); ! ! /* non_zerosized is true when the selected range is not ! empty. */ ! stride_pos = fold_build2 (GT_EXPR, boolean_type_node, ! info->stride[n], gfc_index_zero_node); ! tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n], ! end); ! stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, ! stride_pos, tmp); ! ! stride_neg = fold_build2 (LT_EXPR, boolean_type_node, ! info->stride[n], gfc_index_zero_node); ! tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n], ! end); ! stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, ! stride_neg, tmp); ! non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, ! stride_pos, stride_neg); ! ! /* Check the start of the range against the lower and upper ! bounds of the array, if the range is not empty. */ ! tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n], ! lbound); ! tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, ! non_zerosized, tmp); ! asprintf (&msg, "%s, lower bound of dimension %d of array '%s'" ! " exceeded", gfc_msg_fault, info->dim[n]+1, ! ss->expr->symtree->name); ! gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where); ! gfc_free (msg); ! ! tmp = fold_build2 (GT_EXPR, boolean_type_node, info->start[n], ! ubound); ! tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, ! non_zerosized, tmp); ! asprintf (&msg, "%s, upper bound of dimension %d of array '%s'" ! " exceeded", gfc_msg_fault, info->dim[n]+1, ! ss->expr->symtree->name); ! gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where); ! gfc_free (msg); ! ! /* Compute the last element of the range, which is not ! necessarily "end" (think 0:5:3, which doesn't contain 5) ! and check it against both lower and upper bounds. */ ! tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, ! info->start[n]); ! tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2, ! info->stride[n]); ! tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, ! tmp2); ! ! tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound); ! tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, ! non_zerosized, tmp); ! asprintf (&msg, "%s, lower bound of dimension %d of array '%s'" ! " exceeded", gfc_msg_fault, info->dim[n]+1, ! ss->expr->symtree->name); ! gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where); ! gfc_free (msg); ! ! tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound); ! tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, ! non_zerosized, tmp); ! asprintf (&msg, "%s, upper bound of dimension %d of array '%s'" ! " exceeded", gfc_msg_fault, info->dim[n]+1, ! ss->expr->symtree->name); ! gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where); ! gfc_free (msg); /* Check the section sizes match. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, *************** gfc_conv_ss_startstride (gfc_loopinfo * *** 2419,2432 **** { tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]); ! fault = ! build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp); } else size[n] = gfc_evaluate_now (tmp, &block); } } - gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block); tmp = gfc_finish_block (&block); gfc_add_expr_to_block (&loop->pre, tmp); --- 2582,2597 ---- { tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]); ! asprintf (&msg, "%s, size mismatch for dimension %d " ! "of array '%s'", gfc_msg_bounds, info->dim[n]+1, ! ss->expr->symtree->name); ! gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where); ! gfc_free (msg); } else size[n] = gfc_evaluate_now (tmp, &block); } } tmp = gfc_finish_block (&block); gfc_add_expr_to_block (&loop->pre, tmp); *************** gfc_conv_loop_setup (gfc_loopinfo * loop *** 2769,2775 **** loop->temp_ss->data.info.dimen = n; gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop, &loop->temp_ss->data.info, tmp, false, ! true); } for (n = 0; n < loop->temp_dim; n++) --- 2934,2940 ---- loop->temp_ss->data.info.dimen = n; gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop, &loop->temp_ss->data.info, tmp, false, ! true, false); } for (n = 0; n < loop->temp_dim; n++) *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 2975,2983 **** --- 3140,3159 ---- gfc_expr **upper; gfc_ref *ref; int allocatable_array; + int must_be_pointer; ref = expr->ref; + /* In Fortran 95, components can only contain pointers, so that, + in ALLOCATE (foo%bar(2)), bar must be a pointer component. + We test this by checking for ref->next. + An implementation of TR 15581 would need to change this. */ + + if (ref) + must_be_pointer = ref->next != NULL; + else + must_be_pointer = 0; + /* Find the last reference in the chain. */ while (ref && ref->next != NULL) { *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 3020,3026 **** tmp = gfc_conv_descriptor_data_addr (se->expr); pointer = gfc_evaluate_now (tmp, &se->pre); ! allocatable_array = expr->symtree->n.sym->attr.allocatable; if (TYPE_PRECISION (gfc_array_index_type) == 32) { --- 3196,3205 ---- tmp = gfc_conv_descriptor_data_addr (se->expr); pointer = gfc_evaluate_now (tmp, &se->pre); ! if (must_be_pointer) ! allocatable_array = 0; ! else ! allocatable_array = expr->symtree->n.sym->attr.allocatable; if (TYPE_PRECISION (gfc_array_index_type) == 32) { *************** gfc_trans_dummy_array_bias (gfc_symbol * *** 3453,3459 **** tree dumdesc; tree tmp; tree stmt; ! tree stride; tree stmt_packed; tree stmt_unpacked; tree partial; --- 3632,3638 ---- tree dumdesc; tree tmp; tree stmt; ! tree stride, stride2; tree stmt_packed; tree stmt_unpacked; tree partial; *************** gfc_trans_dummy_array_bias (gfc_symbol * *** 3597,3609 **** if (checkparm) { /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound); ! stride = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound); ! tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride); ! gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block); } } else --- 3776,3792 ---- if (checkparm) { /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ + char * msg; tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound); ! stride2 = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound); ! tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2); ! asprintf (&msg, "%s for dimension %d of array '%s'", ! gfc_msg_bounds, n+1, sym->name); ! gfc_trans_runtime_check (tmp, msg, &block, NULL); ! gfc_free (msg); } } else *************** gfc_conv_expr_descriptor (gfc_se * se, g *** 3907,3915 **** loop.temp_ss->next = gfc_ss_terminator; if (expr->ts.type == BT_CHARACTER) { ! if (expr->ts.cl ! && expr->ts.cl->length ! && expr->ts.cl->length->expr_type == EXPR_CONSTANT) { expr->ts.cl->backend_decl = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer, --- 4090,4129 ---- loop.temp_ss->next = gfc_ss_terminator; if (expr->ts.type == BT_CHARACTER) { ! if (expr->ts.cl == NULL) ! { ! /* This had better be a substring reference! */ ! gfc_ref *char_ref = expr->ref; ! for (; char_ref; char_ref = char_ref->next) ! if (char_ref->type == REF_SUBSTRING) ! { ! mpz_t char_len; ! expr->ts.cl = gfc_get_charlen (); ! expr->ts.cl->next = char_ref->u.ss.length->next; ! char_ref->u.ss.length->next = expr->ts.cl; ! ! mpz_init_set_ui (char_len, 1); ! mpz_add (char_len, char_len, ! char_ref->u.ss.end->value.integer); ! mpz_sub (char_len, char_len, ! char_ref->u.ss.start->value.integer); ! expr->ts.cl->backend_decl ! = gfc_conv_mpz_to_tree (char_len, ! gfc_default_character_kind); ! /* Cast is necessary for *-charlen refs. */ ! expr->ts.cl->backend_decl ! = convert (gfc_charlen_type_node, ! expr->ts.cl->backend_decl); ! mpz_clear (char_len); ! break; ! } ! gcc_assert (char_ref != NULL); ! loop.temp_ss->data.temp.type ! = gfc_typenode_for_spec (&expr->ts); ! loop.temp_ss->string_length = expr->ts.cl->backend_decl; ! } ! else if (expr->ts.cl->length ! && expr->ts.cl->length->expr_type == EXPR_CONSTANT) { expr->ts.cl->backend_decl = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer, *************** gfc_conv_expr_descriptor (gfc_se * se, g *** 3979,3988 **** /* Finish the copying loops. */ gfc_trans_scalarizing_loops (&loop, &block); - /* Set the first stride component to zero to indicate a temporary. */ desc = loop.temp_ss->data.info.descriptor; - tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]); - gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node); gcc_assert (is_gimple_lvalue (desc)); } --- 4193,4199 ---- diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-array.h gcc-4.1.2/gcc/fortran/trans-array.h *** gcc-4.1.1/gcc/fortran/trans-array.h Sat Apr 8 17:05:52 2006 --- gcc-4.1.2/gcc/fortran/trans-array.h Sun Jul 16 10:11:57 2006 *************** void gfc_set_loop_bounds_from_array_spec *** 33,39 **** /* Generate code to allocate a temporary array. */ tree gfc_trans_allocate_temp_array (stmtblock_t *, stmtblock_t *, gfc_loopinfo *, gfc_ss_info *, tree, bool, ! bool); /* Generate function entry code for allocation of compiler allocated array variables. */ --- 33,39 ---- /* Generate code to allocate a temporary array. */ tree gfc_trans_allocate_temp_array (stmtblock_t *, stmtblock_t *, gfc_loopinfo *, gfc_ss_info *, tree, bool, ! bool, bool); /* Generate function entry code for allocation of compiler allocated array variables. */ *************** void gfc_conv_resolve_dependencies (gfc_ *** 85,91 **** tree gfc_build_null_descriptor (tree); /* Get a single array element. */ ! void gfc_conv_array_ref (gfc_se *, gfc_array_ref *); /* Translate a reference to a temporary array. */ void gfc_conv_tmp_array_ref (gfc_se * se); /* Translate a reference to an array temporary. */ --- 85,91 ---- tree gfc_build_null_descriptor (tree); /* Get a single array element. */ ! void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_symbol *, locus *); /* Translate a reference to a temporary array. */ void gfc_conv_tmp_array_ref (gfc_se * se); /* Translate a reference to an array temporary. */ diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-common.c gcc-4.1.2/gcc/fortran/trans-common.c *** gcc-4.1.1/gcc/fortran/trans-common.c Mon May 8 05:01:56 2006 --- gcc-4.1.2/gcc/fortran/trans-common.c Sun Jul 16 17:17:04 2006 *************** translate_common (gfc_common_head *commo *** 951,956 **** --- 951,963 ---- current_offset += s->length; } + if (common_segment == NULL) + { + gfc_error ("COMMON '%s' at %L does not exist", + common->name, &common->where); + return; + } + if (common_segment->offset != 0) { gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start", diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-const.c gcc-4.1.2/gcc/fortran/trans-const.c *** gcc-4.1.1/gcc/fortran/trans-const.c Sat Sep 17 18:58:01 2005 --- gcc-4.1.2/gcc/fortran/trans-const.c Wed Jun 28 05:36:08 2006 *************** Software Foundation, 51 Franklin Street, *** 33,44 **** #include "trans-const.h" #include "trans-types.h" - /* String constants. */ - tree gfc_strconst_bounds; - tree gfc_strconst_fault; - tree gfc_strconst_wrong_return; - tree gfc_strconst_current_filename; - tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1]; /* Build a constant with given type from an int_cst. */ --- 33,38 ---- *************** gfc_init_constants (void) *** 154,170 **** for (n = 0; n <= GFC_MAX_DIMENSIONS; n++) gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n); - - gfc_strconst_bounds = gfc_build_cstring_const ("Array bound mismatch"); - - gfc_strconst_fault = - gfc_build_cstring_const ("Array reference out of bounds"); - - gfc_strconst_wrong_return = - gfc_build_cstring_const ("Incorrect function return value"); - - gfc_strconst_current_filename = - gfc_build_cstring_const (gfc_source_file); } /* Converts a GMP integer into a backend tree node. */ --- 148,153 ---- *************** gfc_conv_mpfr_to_tree (mpfr_t f, int kin *** 226,236 **** --- 209,239 ---- mp_exp_t exp; char *p, *q; int n; + REAL_VALUE_TYPE real; n = gfc_validate_kind (BT_REAL, kind, false); gcc_assert (gfc_real_kinds[n].radix == 2); + type = gfc_get_real_type (kind); + + /* Take care of Infinity and NaN. */ + if (mpfr_inf_p (f)) + { + real_inf (&real); + if (mpfr_sgn (f) < 0) + real = REAL_VALUE_NEGATE(real); + res = build_real (type , real); + return res; + } + + if (mpfr_nan_p (f)) + { + real_nan (&real, "", 0, TYPE_MODE (type)); + res = build_real (type , real); + return res; + } + /* mpfr chooses too small a number of hexadecimal digits if the number of binary digits is not divisible by four, therefore we have to explicitly request a sufficient number of digits here. */ *************** gfc_conv_mpfr_to_tree (mpfr_t f, int kin *** 251,257 **** else sprintf (q, "0x.%sp%d", p, (int) exp); - type = gfc_get_real_type (kind); res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type))); gfc_free (q); --- 254,259 ---- diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-const.h gcc-4.1.2/gcc/fortran/trans-const.h *** gcc-4.1.1/gcc/fortran/trans-const.h Sat Jun 25 00:40:37 2005 --- gcc-4.1.2/gcc/fortran/trans-const.h Tue Jun 20 06:04:14 2006 *************** void gfc_init_constants (void); *** 49,60 **** /* Build a constant with given type from an int_cst. */ tree gfc_build_const (tree, tree); - /* String constants. */ - extern GTY(()) tree gfc_strconst_current_filename; - extern GTY(()) tree gfc_strconst_bounds; - extern GTY(()) tree gfc_strconst_fault; - extern GTY(()) tree gfc_strconst_wrong_return; - /* Integer constants 0..GFC_MAX_DIMENSIONS. */ extern GTY(()) tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1]; --- 49,54 ---- diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-decl.c gcc-4.1.2/gcc/fortran/trans-decl.c *** gcc-4.1.1/gcc/fortran/trans-decl.c Sun Apr 23 05:33:16 2006 --- gcc-4.1.2/gcc/fortran/trans-decl.c Fri Oct 6 07:33:34 2006 *************** gfc_finish_var_decl (tree decl, gfc_symb *** 508,514 **** /* Keep variables larger than max-stack-var-size off stack. */ if (!sym->ns->proc_name->attr.recursive && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) ! && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))) TREE_STATIC (decl) = 1; } --- 508,521 ---- /* Keep variables larger than max-stack-var-size off stack. */ if (!sym->ns->proc_name->attr.recursive && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) ! && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) ! /* Put variable length auto array pointers always into stack. */ ! && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE ! || sym->attr.dimension == 0 ! || sym->as->type != AS_EXPLICIT ! || sym->attr.pointer ! || sym->attr.allocatable) ! && !DECL_ARTIFICIAL (decl)) TREE_STATIC (decl) = 1; } *************** gfc_build_dummy_array_decl (gfc_symbol * *** 696,701 **** --- 703,709 ---- /* We now have an expression for the element size, so create a fully qualified type. Reset sym->backend decl or this will just return the old type. */ + DECL_ARTIFICIAL (sym->backend_decl) = 1; sym->backend_decl = NULL_TREE; type = gfc_sym_type (sym); packed = 2; *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 875,882 **** /* Use a copy of the descriptor for dummy arrays. */ if (sym->attr.dimension && !TREE_USED (sym->backend_decl)) { ! sym->backend_decl = ! gfc_build_dummy_array_decl (sym, sym->backend_decl); } TREE_USED (sym->backend_decl) = 1; --- 883,893 ---- /* Use a copy of the descriptor for dummy arrays. */ if (sym->attr.dimension && !TREE_USED (sym->backend_decl)) { ! decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); ! /* Prevent the dummy from being detected as unused if it is copied. */ ! if (sym->backend_decl != NULL && decl != sym->backend_decl) ! DECL_ARTIFICIAL (sym->backend_decl) = 1; ! sym->backend_decl = decl; } TREE_USED (sym->backend_decl) = 1; *************** create_function_arglist (gfc_symbol * sy *** 1267,1272 **** --- 1278,1284 ---- DECL_ARG_TYPE (parm) = type; TREE_READONLY (parm) = 1; gfc_finish_decl (parm, NULL_TREE); + DECL_ARTIFICIAL (parm) = 1; arglist = chainon (arglist, parm); typelist = TREE_CHAIN (typelist); *************** build_entry_thunks (gfc_namespace * ns) *** 1526,1531 **** --- 1538,1544 ---- if (thunk_formal) { /* Pass the argument. */ + DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1; args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl, args); if (formal->sym->ts.type == BT_CHARACTER) *************** gfc_build_builtin_function_decls (void) *** 2145,2154 **** gfor_fndecl_runtime_error = gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")), ! void_type_node, ! 3, ! pchar_type_node, pchar_type_node, ! gfc_int4_type_node); /* The runtime_error function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1; --- 2158,2164 ---- gfor_fndecl_runtime_error = gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")), ! void_type_node, 1, pchar_type_node); /* The runtime_error function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1; *************** gfc_create_module_variable (gfc_symbol * *** 2394,2399 **** --- 2404,2414 ---- { tree decl; + /* Module functions with alternate entries are dealt with later and + would get caught by the next condition. */ + if (sym->attr.entry) + return; + /* Only output symbols from this module. */ if (sym->ns != module_namespace) { *************** gfc_generate_contained_functions (gfc_na *** 2487,2492 **** --- 2502,2613 ---- } + /* Drill down through expressions for the array specification bounds and + character length calling generate_local_decl for all those variables + that have not already been declared. */ + + static void + generate_local_decl (gfc_symbol *); + + static void + generate_expr_decls (gfc_symbol *sym, gfc_expr *e) + { + gfc_actual_arglist *arg; + gfc_ref *ref; + int i; + + if (e == NULL) + return; + + switch (e->expr_type) + { + case EXPR_FUNCTION: + for (arg = e->value.function.actual; arg; arg = arg->next) + generate_expr_decls (sym, arg->expr); + break; + + /* If the variable is not the same as the dependent, 'sym', and + it is not marked as being declared and it is in the same + namespace as 'sym', add it to the local declarations. */ + case EXPR_VARIABLE: + if (sym == e->symtree->n.sym + || e->symtree->n.sym->mark + || e->symtree->n.sym->ns != sym->ns) + return; + + generate_local_decl (e->symtree->n.sym); + break; + + case EXPR_OP: + generate_expr_decls (sym, e->value.op.op1); + generate_expr_decls (sym, e->value.op.op2); + break; + + default: + break; + } + + if (e->ref) + { + for (ref = e->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + for (i = 0; i < ref->u.ar.dimen; i++) + { + generate_expr_decls (sym, ref->u.ar.start[i]); + generate_expr_decls (sym, ref->u.ar.end[i]); + generate_expr_decls (sym, ref->u.ar.stride[i]); + } + break; + + case REF_SUBSTRING: + generate_expr_decls (sym, ref->u.ss.start); + generate_expr_decls (sym, ref->u.ss.end); + break; + + case REF_COMPONENT: + if (ref->u.c.component->ts.type == BT_CHARACTER + && ref->u.c.component->ts.cl->length->expr_type + != EXPR_CONSTANT) + generate_expr_decls (sym, ref->u.c.component->ts.cl->length); + + if (ref->u.c.component->as) + for (i = 0; i < ref->u.c.component->as->rank; i++) + { + generate_expr_decls (sym, ref->u.c.component->as->lower[i]); + generate_expr_decls (sym, ref->u.c.component->as->upper[i]); + } + break; + } + } + } + } + + + /* Check for dependencies in the character length and array spec. */ + + static void + generate_dependency_declarations (gfc_symbol *sym) + { + int i; + + if (sym->ts.type == BT_CHARACTER + && sym->ts.cl->length->expr_type != EXPR_CONSTANT) + generate_expr_decls (sym, sym->ts.cl->length); + + if (sym->as && sym->as->rank) + { + for (i = 0; i < sym->as->rank; i++) + { + generate_expr_decls (sym, sym->as->lower[i]); + generate_expr_decls (sym, sym->as->upper[i]); + } + } + } + + /* Generate decls for all local variables. We do this to ensure correct handling of expressions which only appear in the specification of other functions. */ *************** generate_local_decl (gfc_symbol * sym) *** 2496,2510 **** { if (sym->attr.flavor == FL_VARIABLE) { if (sym->attr.referenced) gfc_get_symbol_decl (sym); else if (sym->attr.dummy && warn_unused_parameter) ! warning (0, "unused parameter %qs", sym->name); /* Warn for unused variables, but not if they're inside a common block or are use-associated. */ else if (warn_unused_variable && !(sym->attr.in_common || sym->attr.use_assoc)) ! warning (0, "unused variable %qs", sym->name); } } --- 2617,2641 ---- { if (sym->attr.flavor == FL_VARIABLE) { + /* Check for dependencies in the array specification and string + length, adding the necessary declarations to the function. We + mark the symbol now, as well as in traverse_ns, to prevent + getting stuck in a circular dependency. */ + sym->mark = 1; + if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master) + generate_dependency_declarations (sym); + if (sym->attr.referenced) gfc_get_symbol_decl (sym); else if (sym->attr.dummy && warn_unused_parameter) ! gfc_warning ("Unused parameter %s declared at %L", sym->name, ! &sym->declared_at); /* Warn for unused variables, but not if they're inside a common block or are use-associated. */ else if (warn_unused_variable && !(sym->attr.in_common || sym->attr.use_assoc)) ! gfc_warning ("Unused variable %s declared at %L", sym->name, ! &sym->declared_at); } } diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-expr.c gcc-4.1.2/gcc/fortran/trans-expr.c *** gcc-4.1.1/gcc/fortran/trans-expr.c Sun Apr 23 05:33:16 2006 --- gcc-4.1.2/gcc/fortran/trans-expr.c Wed Dec 13 22:37:21 2006 *************** gfc_conv_substring (gfc_se * se, gfc_ref *** 271,282 **** gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node); gfc_add_block_to_block (&se->pre, &end.pre); } ! tmp = ! build2 (MINUS_EXPR, gfc_charlen_type_node, ! fold_convert (gfc_charlen_type_node, integer_one_node), ! start.expr); ! tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp); ! se->string_length = fold (tmp); } --- 271,283 ---- gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node); gfc_add_block_to_block (&se->pre, &end.pre); } ! tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, ! build_int_cst (gfc_charlen_type_node, 1), ! start.expr); ! tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp); ! tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp, ! build_int_cst (gfc_charlen_type_node, 0)); ! se->string_length = tmp; } *************** gfc_conv_variable (gfc_se * se, gfc_expr *** 452,458 **** && ref->next == NULL && (se->descriptor_only)) return; ! gfc_conv_array_ref (se, &ref->u.ar); /* Return a pointer to an element. */ break; --- 453,459 ---- && ref->next == NULL && (se->descriptor_only)) return; ! gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where); /* Return a pointer to an element. */ break; *************** gfc_set_interface_mapping_bounds (stmtbl *** 1273,1282 **** offset = gfc_index_zero_node; for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++) { GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n); ! if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE) { - dim = gfc_rank_cst[n]; tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, gfc_conv_descriptor_ubound (desc, dim), gfc_conv_descriptor_lbound (desc, dim)); --- 1274,1290 ---- offset = gfc_index_zero_node; for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++) { + dim = gfc_rank_cst[n]; GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n); ! if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE) ! { ! GFC_TYPE_ARRAY_LBOUND (type, n) ! = gfc_conv_descriptor_lbound (desc, dim); ! GFC_TYPE_ARRAY_UBOUND (type, n) ! = gfc_conv_descriptor_ubound (desc, dim); ! } ! else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE) { tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, gfc_conv_descriptor_ubound (desc, dim), gfc_conv_descriptor_lbound (desc, dim)); *************** gfc_apply_interface_mapping (gfc_interfa *** 1567,1573 **** handling aliased arrays. */ static void ! gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77) { gfc_se lse; gfc_se rse; --- 1575,1582 ---- handling aliased arrays. */ static void ! gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, ! int g77, sym_intent intent) { gfc_se lse; gfc_se rse; *************** gfc_conv_aliased_arg (gfc_se * parmse, g *** 1611,1617 **** loop.temp_ss->data.temp.type = base_type; if (expr->ts.type == BT_CHARACTER) ! loop.temp_ss->string_length = expr->ts.cl->backend_decl; loop.temp_ss->data.temp.dimen = loop.dimen; loop.temp_ss->next = gfc_ss_terminator; --- 1620,1656 ---- loop.temp_ss->data.temp.type = base_type; if (expr->ts.type == BT_CHARACTER) ! { ! gfc_ref *char_ref = expr->ref; ! ! for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next) ! if (char_ref->type == REF_SUBSTRING) ! { ! gfc_se tmp_se; ! ! expr->ts.cl = gfc_get_charlen (); ! expr->ts.cl->next = char_ref->u.ss.length->next; ! char_ref->u.ss.length->next = expr->ts.cl; ! ! gfc_init_se (&tmp_se, NULL); ! gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end, ! gfc_array_index_type); ! tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ! tmp_se.expr, gfc_index_one_node); ! tmp = gfc_evaluate_now (tmp, &parmse->pre); ! gfc_init_se (&tmp_se, NULL); ! gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start, ! gfc_array_index_type); ! tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, ! tmp, tmp_se.expr); ! expr->ts.cl->backend_decl = tmp; ! ! break; ! } ! loop.temp_ss->data.temp.type ! = gfc_typenode_for_spec (&expr->ts); ! loop.temp_ss->string_length = expr->ts.cl->backend_decl; ! } loop.temp_ss->data.temp.dimen = loop.dimen; loop.temp_ss->next = gfc_ss_terminator; *************** gfc_conv_aliased_arg (gfc_se * parmse, g *** 1644,1655 **** gfc_conv_tmp_array_ref (&lse); gfc_advance_se_ss_chain (&lse); ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); ! gfc_add_expr_to_block (&body, tmp); ! ! gcc_assert (rse.ss == gfc_ss_terminator); ! ! gfc_trans_scalarizing_loops (&loop, &body); /* Add the post block after the second loop, so that any freeing of allocated memory is done at the right time. */ --- 1683,1706 ---- gfc_conv_tmp_array_ref (&lse); gfc_advance_se_ss_chain (&lse); ! if (intent != INTENT_OUT) ! { ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); ! gfc_add_expr_to_block (&body, tmp); ! gcc_assert (rse.ss == gfc_ss_terminator); ! gfc_trans_scalarizing_loops (&loop, &body); ! } ! else ! { ! /* Make sure that the temporary declaration survives by merging ! all the loop declarations into the current context. */ ! for (n = 0; n < loop.dimen; n++) ! { ! gfc_merge_block_scope (&body); ! body = loop.code[loop.order[n]]; ! } ! gfc_merge_block_scope (&body); ! } /* Add the post block after the second loop, so that any freeing of allocated memory is done at the right time. */ *************** gfc_conv_aliased_arg (gfc_se * parmse, g *** 1737,1746 **** gfc_trans_scalarizing_loops (&loop2, &body); /* Wrap the whole thing up by adding the second loop to the post-block ! and following it by the post-block of the fist loop. In this way, if the temporary needs freeing, it is done after use! */ ! gfc_add_block_to_block (&parmse->post, &loop2.pre); ! gfc_add_block_to_block (&parmse->post, &loop2.post); gfc_add_block_to_block (&parmse->post, &loop.post); --- 1788,1800 ---- gfc_trans_scalarizing_loops (&loop2, &body); /* Wrap the whole thing up by adding the second loop to the post-block ! and following it by the post-block of the first loop. In this way, if the temporary needs freeing, it is done after use! */ ! if (intent != INTENT_IN) ! { ! gfc_add_block_to_block (&parmse->post, &loop2.pre); ! gfc_add_block_to_block (&parmse->post, &loop2.post); ! } gfc_add_block_to_block (&parmse->post, &loop.post); *************** is_aliased_array (gfc_expr * e) *** 1775,1781 **** if (ref->type == REF_ARRAY) seen_array = true; ! if (ref->next == NULL && ref->type == REF_COMPONENT) return seen_array; } return false; --- 1829,1836 ---- if (ref->type == REF_ARRAY) seen_array = true; ! if (ref->next == NULL ! && ref->type != REF_ARRAY) return seen_array; } return false; *************** gfc_conv_function_call (gfc_se * se, gfc *** 1914,1940 **** && !fsym->attr.pointer && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; if (e->expr_type == EXPR_VARIABLE && is_aliased_array (e)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then written back after the procedure call. */ ! gfc_conv_aliased_arg (&parmse, e, f); else gfc_conv_array_parameter (&parmse, e, argss, f); } } ! /* If an optional argument is itself an optional dummy argument, ! check its presence and substitute a null if absent. */ ! if (e && e->expr_type == EXPR_VARIABLE ! && e->symtree->n.sym->attr.optional ! && fsym && fsym->attr.optional) ! gfc_conv_missing_dummy (&parmse, e, fsym->ts); ! if (fsym && need_interface_mapping) ! gfc_add_interface_mapping (&mapping, fsym, &parmse); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&post, &parmse.post); --- 1969,2028 ---- && !fsym->attr.pointer && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; + if (e->expr_type == EXPR_VARIABLE && is_aliased_array (e)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then written back after the procedure call. */ ! gfc_conv_aliased_arg (&parmse, e, f, ! fsym ? fsym->attr.intent : INTENT_INOUT); else gfc_conv_array_parameter (&parmse, e, argss, f); } } ! if (fsym) ! { ! if (e) ! { ! /* If an optional argument is itself an optional dummy ! argument, check its presence and substitute a null ! if absent. */ ! if (e->expr_type == EXPR_VARIABLE ! && e->symtree->n.sym->attr.optional ! && fsym->attr.optional) ! gfc_conv_missing_dummy (&parmse, e, fsym->ts); ! /* If an INTENT(OUT) dummy of derived type has a default ! initializer, it must be (re)initialized here. */ ! if (fsym->attr.intent == INTENT_OUT ! && fsym->ts.type == BT_DERIVED ! && fsym->value) ! { ! gcc_assert (!fsym->attr.allocatable); ! tmp = gfc_trans_assignment (e, fsym->value); ! gfc_add_expr_to_block (&se->pre, tmp); ! } ! ! /* Obtain the character length of an assumed character ! length procedure from the typespec. */ ! if (fsym->ts.type == BT_CHARACTER ! && parmse.string_length == NULL_TREE ! && e->ts.type == BT_PROCEDURE ! && e->symtree->n.sym->ts.type == BT_CHARACTER ! && e->symtree->n.sym->ts.cl->length != NULL) ! { ! gfc_conv_const_charlen (e->symtree->n.sym->ts.cl); ! parmse.string_length ! = e->symtree->n.sym->ts.cl->backend_decl; ! } ! } ! ! if (need_interface_mapping) ! gfc_add_interface_mapping (&mapping, fsym, &parmse); ! } gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&post, &parmse.post); *************** gfc_conv_function_call (gfc_se * se, gfc *** 1955,1966 **** { /* Assumed character length results are not allowed by 5.1.1.5 of the standard and are trapped in resolve.c; except in the case of SPREAD ! (and other intrinsics?). In this case, we take the character length ! of the first argument for the result. */ ! cl.backend_decl = TREE_VALUE (stringargs); ! } ! else ! { /* Calculate the length of the returned string. */ gfc_init_se (&parmse, NULL); if (need_interface_mapping) --- 2043,2064 ---- { /* Assumed character length results are not allowed by 5.1.1.5 of the standard and are trapped in resolve.c; except in the case of SPREAD ! (and other intrinsics?) and dummy functions. In the case of SPREAD, ! we take the character length of the first argument for the result. ! For dummies, we have to look through the formal argument list for ! this function and use the character length found there.*/ ! if (!sym->attr.dummy) ! cl.backend_decl = TREE_VALUE (stringargs); ! else ! { ! formal = sym->ns->proc_name->formal; ! for (; formal; formal = formal->next) ! if (strcmp (formal->sym->name, sym->name) == 0) ! cl.backend_decl = formal->sym->ts.cl->backend_decl; ! } ! } ! else ! { /* Calculate the length of the returned string. */ gfc_init_se (&parmse, NULL); if (need_interface_mapping) *************** gfc_conv_function_call (gfc_se * se, gfc *** 2000,2011 **** returns a pointer, the temporary will be a shallow copy and mustn't be deallocated. */ gfc_trans_allocate_temp_array (&se->pre, &se->post, se->loop, info, ! tmp, false, !sym->attr.pointer); ! ! /* Zero the first stride to indicate a temporary. */ ! tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]); ! gfc_add_modify_expr (&se->pre, tmp, ! convert (TREE_TYPE (tmp), integer_zero_node)); /* Pass the temporary as the first argument. */ tmp = info->descriptor; --- 2098,2104 ---- returns a pointer, the temporary will be a shallow copy and mustn't be deallocated. */ gfc_trans_allocate_temp_array (&se->pre, &se->post, se->loop, info, ! tmp, false, !sym->attr.pointer, true); /* Pass the temporary as the first argument. */ tmp = info->descriptor; *************** gfc_conv_function_call (gfc_se * se, gfc *** 2118,2124 **** happen in a function returning a pointer. */ tmp = gfc_conv_descriptor_data_get (info->descriptor); tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data); ! gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre); } se->expr = info->descriptor; /* Bundle in the string length. */ --- 2211,2217 ---- happen in a function returning a pointer. */ tmp = gfc_conv_descriptor_data_get (info->descriptor); tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data); ! gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL); } se->expr = info->descriptor; /* Bundle in the string length. */ *************** gfc_trans_string_copy (stmtblock_t * blo *** 2161,2166 **** --- 2254,2260 ---- tree tmp; tree dsc; tree ssc; + tree cond; /* Deal with single character specially. */ dsc = gfc_to_single_character (dlen, dest); *************** gfc_trans_string_copy (stmtblock_t * blo *** 2171,2182 **** --- 2265,2280 ---- return; } + cond = fold_build2 (GT_EXPR, boolean_type_node, dlen, + build_int_cst (gfc_charlen_type_node, 0)); + tmp = NULL_TREE; tmp = gfc_chainon_list (tmp, dlen); tmp = gfc_chainon_list (tmp, dest); tmp = gfc_chainon_list (tmp, slen); tmp = gfc_chainon_list (tmp, src); tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp); + tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ()); gfc_add_expr_to_block (block, tmp); } *************** gfc_trans_subcomponent_assign (tree dest *** 2525,2533 **** } else if (expr->ts.type == BT_DERIVED) { ! /* Nested derived type. */ ! tmp = gfc_trans_structure_assign (dest, expr); ! gfc_add_expr_to_block (&block, tmp); } else { --- 2623,2641 ---- } else if (expr->ts.type == BT_DERIVED) { ! if (expr->expr_type != EXPR_STRUCTURE) ! { ! gfc_init_se (&se, NULL); ! gfc_conv_expr (&se, expr); ! gfc_add_modify_expr (&block, dest, ! fold_convert (TREE_TYPE (dest), se.expr)); ! } ! else ! { ! /* Nested constructors. */ ! tmp = gfc_trans_structure_assign (dest, expr); ! gfc_add_expr_to_block (&block, tmp); ! } } else { *************** gfc_conv_expr_reference (gfc_se * se, gf *** 2777,2784 **** /* Create a temporary var to hold the value. */ if (TREE_CONSTANT (se->expr)) { ! var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr)); ! DECL_INITIAL (var) = se->expr; pushdecl (var); } else --- 2885,2894 ---- /* Create a temporary var to hold the value. */ if (TREE_CONSTANT (se->expr)) { ! tree tmp = se->expr; ! STRIP_TYPE_NOPS (tmp); ! var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp)); ! DECL_INITIAL (var) = tmp; pushdecl (var); } else *************** gfc_trans_pointer_assignment (gfc_expr * *** 2843,2849 **** { case EXPR_NULL: /* Just set the data pointer to null. */ ! gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node); break; case EXPR_VARIABLE: --- 2953,2959 ---- { case EXPR_NULL: /* Just set the data pointer to null. */ ! gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node); break; case EXPR_VARIABLE: *************** gfc_trans_assignment (gfc_expr * expr1, *** 3163,3168 **** --- 3273,3284 ---- } tree + gfc_trans_init_assign (gfc_code * code) + { + return gfc_trans_assignment (code->expr, code->expr2); + } + + tree gfc_trans_assign (gfc_code * code) { return gfc_trans_assignment (code->expr, code->expr2); diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-intrinsic.c gcc-4.1.2/gcc/fortran/trans-intrinsic.c *** gcc-4.1.1/gcc/fortran/trans-intrinsic.c Mon May 8 05:01:56 2006 --- gcc-4.1.2/gcc/fortran/trans-intrinsic.c Wed Jan 24 21:26:59 2007 *************** *** 1,5 **** /* Intrinsic translation ! Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher --- 1,6 ---- /* Intrinsic translation ! Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 ! Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher *************** gfc_conv_intrinsic_bound (gfc_se * se, g *** 702,711 **** tree type; tree bound; tree tmp; ! tree cond; gfc_se argse; gfc_ss *ss; ! int i; arg = expr->value.function.actual; arg2 = arg->next; --- 703,715 ---- tree type; tree bound; tree tmp; ! tree cond, cond1, cond2, cond3, cond4, size; ! tree ubound; ! tree lbound; gfc_se argse; gfc_ss *ss; ! gfc_array_spec * as; ! gfc_ref *ref; arg = expr->value.function.actual; arg2 = arg->next; *************** gfc_conv_intrinsic_bound (gfc_se * se, g *** 747,755 **** if (INTEGER_CST_P (bound)) { ! gcc_assert (TREE_INT_CST_HIGH (bound) == 0); ! i = TREE_INT_CST_LOW (bound); ! gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))); } else { --- 751,764 ---- if (INTEGER_CST_P (bound)) { ! int hi, low; ! ! hi = TREE_INT_CST_HIGH (bound); ! low = TREE_INT_CST_LOW (bound); ! if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) ! gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " ! "dimension index", upper ? "UBOUND" : "LBOUND", ! &expr->where); } else { *************** gfc_conv_intrinsic_bound (gfc_se * se, g *** 761,774 **** tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); ! gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre); } } ! if (upper) ! se->expr = gfc_conv_descriptor_ubound(desc, bound); else ! se->expr = gfc_conv_descriptor_lbound(desc, bound); type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, se->expr); --- 770,888 ---- tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); ! gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, NULL); } } ! ubound = gfc_conv_descriptor_ubound (desc, bound); ! lbound = gfc_conv_descriptor_lbound (desc, bound); ! ! /* Follow any component references. */ ! if (arg->expr->expr_type == EXPR_VARIABLE ! || arg->expr->expr_type == EXPR_CONSTANT) ! { ! as = arg->expr->symtree->n.sym->as; ! for (ref = arg->expr->ref; ref; ref = ref->next) ! { ! switch (ref->type) ! { ! case REF_COMPONENT: ! as = ref->u.c.component->as; ! continue; ! ! case REF_SUBSTRING: ! continue; ! ! case REF_ARRAY: ! { ! switch (ref->u.ar.type) ! { ! case AR_ELEMENT: ! case AR_SECTION: ! case AR_UNKNOWN: ! as = NULL; ! continue; ! ! case AR_FULL: ! break; ! } ! } ! } ! } ! } else ! as = NULL; ! ! /* 13.14.53: Result value for LBOUND ! ! Case (i): For an array section or for an array expression other than a ! whole array or array structure component, LBOUND(ARRAY, DIM) ! has the value 1. For a whole array or array structure ! component, LBOUND(ARRAY, DIM) has the value: ! (a) equal to the lower bound for subscript DIM of ARRAY if ! dimension DIM of ARRAY does not have extent zero ! or if ARRAY is an assumed-size array of rank DIM, ! or (b) 1 otherwise. ! ! 13.14.113: Result value for UBOUND ! ! Case (i): For an array section or for an array expression other than a ! whole array or array structure component, UBOUND(ARRAY, DIM) ! has the value equal to the number of elements in the given ! dimension; otherwise, it has a value equal to the upper bound ! for subscript DIM of ARRAY if dimension DIM of ARRAY does ! not have size zero and has value zero if dimension DIM has ! size zero. */ ! ! if (as) ! { ! tree stride = gfc_conv_descriptor_stride (desc, bound); ! ! cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound); ! cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound); ! ! cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride, ! gfc_index_zero_node); ! cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1); ! ! cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride, ! gfc_index_zero_node); ! cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2); ! ! if (upper) ! { ! cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); ! ! se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, ! ubound, gfc_index_zero_node); ! } ! else ! { ! if (as->type == AS_ASSUMED_SIZE) ! cond = fold_build2 (EQ_EXPR, boolean_type_node, bound, ! build_int_cst (TREE_TYPE (bound), ! arg->expr->rank - 1)); ! else ! cond = boolean_false_node; ! ! cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); ! cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1); ! ! se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, ! lbound, gfc_index_one_node); ! } ! } ! else ! { ! if (upper) ! { ! size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound); ! se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, ! gfc_index_one_node); ! } ! else ! se->expr = gfc_index_one_node; ! } type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, se->expr); *************** gfc_conv_intrinsic_mod (gfc_se * se, gfc *** 860,876 **** tree test; tree test2; mpfr_t huge; ! int n; arg = gfc_conv_intrinsic_function_args (se, expr); - arg2 = TREE_VALUE (TREE_CHAIN (arg)); - arg = TREE_VALUE (arg); - type = TREE_TYPE (arg); switch (expr->ts.type) { case BT_INTEGER: /* Integer case is easy, we've got a builtin op. */ if (modulo) se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2); else --- 974,991 ---- tree test; tree test2; mpfr_t huge; ! int n, ikind; arg = gfc_conv_intrinsic_function_args (se, expr); switch (expr->ts.type) { case BT_INTEGER: /* Integer case is easy, we've got a builtin op. */ + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + if (modulo) se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2); else *************** gfc_conv_intrinsic_mod (gfc_se * se, gfc *** 878,892 **** break; case BT_REAL: ! /* Real values we have to do the hard way. */ arg = gfc_evaluate_now (arg, &se->pre); arg2 = gfc_evaluate_now (arg2, &se->pre); tmp = build2 (RDIV_EXPR, type, arg, arg2); /* Test if the value is too large to handle sensibly. */ gfc_set_model_kind (expr->ts.kind); mpfr_init (huge); ! n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false); mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind); test2 = build2 (LT_EXPR, boolean_type_node, tmp, test); --- 993,1071 ---- break; case BT_REAL: ! n = END_BUILTINS; ! /* Check if we have a builtin fmod. */ ! switch (expr->ts.kind) ! { ! case 4: ! n = BUILT_IN_FMODF; ! break; ! ! case 8: ! n = BUILT_IN_FMOD; ! break; ! ! case 10: ! case 16: ! n = BUILT_IN_FMODL; ! break; ! ! default: ! break; ! } ! ! /* Use it if it exists. */ ! if (n != END_BUILTINS) ! { ! tmp = built_in_decls[n]; ! se->expr = build_function_call_expr (tmp, arg); ! if (modulo == 0) ! return; ! } ! ! arg2 = TREE_VALUE (TREE_CHAIN (arg)); ! arg = TREE_VALUE (arg); ! type = TREE_TYPE (arg); ! arg = gfc_evaluate_now (arg, &se->pre); arg2 = gfc_evaluate_now (arg2, &se->pre); + /* Definition: + modulo = arg - floor (arg/arg2) * arg2, so + = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2, + where + test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0)) + thereby avoiding another division and retaining the accuracy + of the builtin function. */ + if (n != END_BUILTINS && modulo) + { + tree zero = gfc_build_const (type, integer_zero_node); + tmp = gfc_evaluate_now (se->expr, &se->pre); + test = build2 (LT_EXPR, boolean_type_node, arg, zero); + test2 = build2 (LT_EXPR, boolean_type_node, arg2, zero); + test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2); + test = build2 (NE_EXPR, boolean_type_node, tmp, zero); + test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); + test = gfc_evaluate_now (test, &se->pre); + se->expr = build3 (COND_EXPR, type, test, + build2 (PLUS_EXPR, type, tmp, arg2), tmp); + return; + } + + /* If we do not have a built_in fmod, the calculation is going to + have to be done longhand. */ tmp = build2 (RDIV_EXPR, type, arg, arg2); + /* Test if the value is too large to handle sensibly. */ gfc_set_model_kind (expr->ts.kind); mpfr_init (huge); ! n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true); ! ikind = expr->ts.kind; ! if (n < 0) ! { ! n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false); ! ikind = gfc_max_integer_kind; ! } mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind); test2 = build2 (LT_EXPR, boolean_type_node, tmp, test); *************** gfc_conv_intrinsic_mod (gfc_se * se, gfc *** 896,902 **** test = build2 (GT_EXPR, boolean_type_node, tmp, test); test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); ! itype = gfc_get_int_type (expr->ts.kind); if (modulo) tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR); else --- 1075,1081 ---- test = build2 (GT_EXPR, boolean_type_node, tmp, test); test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); ! itype = gfc_get_int_type (ikind); if (modulo) tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR); else *************** gfc_conv_intrinsic_sign (gfc_se * se, gf *** 984,989 **** --- 1163,1171 ---- type = TREE_TYPE (arg); zero = gfc_build_const (type, integer_zero_node); + /* Arg is used multiple times below. */ + arg = gfc_evaluate_now (arg, &se->pre); + testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero); testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero); tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb); *************** gfc_conv_intrinsic_len (gfc_se * se, gfc *** 2246,2251 **** --- 2428,2434 ---- gfc_symbol *sym; gfc_se argse; gfc_expr *arg; + gfc_ss *ss; gcc_assert (!se->ss); *************** gfc_conv_intrinsic_len (gfc_se * se, gfc *** 2265,2301 **** get_array_ctor_strlen (arg->value.constructor, &len); break; ! default: ! if (arg->expr_type == EXPR_VARIABLE ! && (arg->ref == NULL || (arg->ref->next == NULL ! && arg->ref->type == REF_ARRAY))) ! { ! /* This doesn't catch all cases. ! See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html ! and the surrounding thread. */ ! sym = arg->symtree->n.sym; ! decl = gfc_get_symbol_decl (sym); ! if (decl == current_function_decl && sym->attr.function && (sym->result == sym)) ! decl = gfc_get_fake_result_decl (sym); ! len = sym->ts.cl->backend_decl; ! gcc_assert (len); ! } ! else ! { ! /* Anybody stupid enough to do this deserves inefficient code. */ ! gfc_init_se (&argse, se); ! gfc_conv_expr (&argse, arg); ! gfc_add_block_to_block (&se->pre, &argse.pre); ! gfc_add_block_to_block (&se->post, &argse.post); ! len = argse.string_length; } break; } se->expr = convert (type, len); } /* The length of a character string not including trailing blanks. */ static void gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) --- 2448,2490 ---- get_array_ctor_strlen (arg->value.constructor, &len); break; ! case EXPR_VARIABLE: ! if (arg->ref == NULL ! || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY)) ! { ! /* This doesn't catch all cases. ! See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html ! and the surrounding thread. */ ! sym = arg->symtree->n.sym; ! decl = gfc_get_symbol_decl (sym); ! if (decl == current_function_decl && sym->attr.function && (sym->result == sym)) ! decl = gfc_get_fake_result_decl (sym); ! len = sym->ts.cl->backend_decl; ! gcc_assert (len); ! break; } + + /* Otherwise fall through. */ + + default: + /* Anybody stupid enough to do this deserves inefficient code. */ + ss = gfc_walk_expr (arg); + gfc_init_se (&argse, se); + if (ss == gfc_ss_terminator) + gfc_conv_expr (&argse, arg); + else + gfc_conv_expr_descriptor (&argse, arg, ss); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + len = argse.string_length; break; } se->expr = convert (type, len); } + /* The length of a character string not including trailing blanks. */ static void gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) *************** gfc_conv_intrinsic_adjust (gfc_se * se, *** 2482,2487 **** --- 2671,2700 ---- } + /* A helper function for gfc_conv_intrinsic_array_transfer to compute + the size of tree expressions in bytes. */ + static tree + gfc_size_in_bytes (gfc_se *se, gfc_expr *e) + { + tree tmp; + + if (e->ts.type == BT_CHARACTER) + tmp = se->string_length; + else + { + if (e->rank) + { + tmp = gfc_get_element_type (TREE_TYPE (se->expr)); + tmp = size_in_bytes (tmp); + } + else + tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr))); + } + + return fold_convert (gfc_array_index_type, tmp); + } + + /* Array transfer statement. DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE]) where: *************** gfc_conv_intrinsic_array_transfer (gfc_s *** 2504,2509 **** --- 2717,2723 ---- tree lower; tree stride; tree stmt; + tree args; gfc_actual_arglist *arg; gfc_se argse; gfc_ss *ss; *************** gfc_conv_intrinsic_array_transfer (gfc_s *** 2530,2537 **** source = argse.expr; /* Obtain the source word length. */ ! tmp = size_in_bytes(TREE_TYPE(TREE_TYPE (source))); ! tmp = fold_convert (gfc_array_index_type, tmp); } else { --- 2744,2750 ---- source = argse.expr; /* Obtain the source word length. */ ! tmp = gfc_size_in_bytes (&argse, arg->expr); } else { *************** gfc_conv_intrinsic_array_transfer (gfc_s *** 2569,2576 **** } /* Obtain the source word length. */ ! tmp = gfc_get_element_type (TREE_TYPE(argse.expr)); ! tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); /* Obtain the size of the array in bytes. */ extent = gfc_create_var (gfc_array_index_type, NULL); --- 2782,2788 ---- } /* Obtain the source word length. */ ! tmp = gfc_size_in_bytes (&argse, arg->expr); /* Obtain the size of the array in bytes. */ extent = gfc_create_var (gfc_array_index_type, NULL); *************** gfc_conv_intrinsic_array_transfer (gfc_s *** 2606,2621 **** if (ss == gfc_ss_terminator) { gfc_conv_expr_reference (&argse, arg->expr); ! tmp = TREE_TYPE(TREE_TYPE (argse.expr)); ! tmp = fold_convert (gfc_array_index_type, size_in_bytes(tmp)); } else { gfc_init_se (&argse, NULL); argse.want_pointer = 0; gfc_conv_expr_descriptor (&argse, arg->expr, ss); ! tmp = gfc_get_element_type (TREE_TYPE(argse.expr)); ! tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); } dest_word_len = gfc_create_var (gfc_array_index_type, NULL); --- 2818,2835 ---- if (ss == gfc_ss_terminator) { gfc_conv_expr_reference (&argse, arg->expr); ! ! /* Obtain the source word length. */ ! tmp = gfc_size_in_bytes (&argse, arg->expr); } else { gfc_init_se (&argse, NULL); argse.want_pointer = 0; gfc_conv_expr_descriptor (&argse, arg->expr, ss); ! ! /* Obtain the source word length. */ ! tmp = gfc_size_in_bytes (&argse, arg->expr); } dest_word_len = gfc_create_var (gfc_array_index_type, NULL); *************** gfc_conv_intrinsic_array_transfer (gfc_s *** 2683,2696 **** se->loop->to[n] = upper; ! /* Build a destination descriptor, using the pointer, source, as the ! data field. This is already allocated so set callee_alloc. */ tmp = gfc_typenode_for_spec (&expr->ts); gfc_trans_allocate_temp_array (&se->pre, &se->post, se->loop, ! info, tmp, false, false); ! tmp = fold_convert (pvoid_type_node, source); ! gfc_conv_descriptor_data_set (&se->pre, info->descriptor, tmp); se->expr = info->descriptor; if (expr->ts.type == BT_CHARACTER) se->string_length = dest_word_len; --- 2897,2917 ---- se->loop->to[n] = upper; ! /* Build a destination descriptor. */ tmp = gfc_typenode_for_spec (&expr->ts); gfc_trans_allocate_temp_array (&se->pre, &se->post, se->loop, ! info, tmp, false, true, false); ! ! /* Use memcpy to do the transfer. */ ! tmp = gfc_conv_descriptor_data_get (info->descriptor); ! args = gfc_chainon_list (NULL_TREE, tmp); tmp = fold_convert (pvoid_type_node, source); ! args = gfc_chainon_list (args, source); ! args = gfc_chainon_list (args, size_bytes); ! tmp = built_in_decls[BUILT_IN_MEMCPY]; ! tmp = build_function_call_expr (tmp, args); ! gfc_add_expr_to_block (&se->pre, tmp); ! se->expr = info->descriptor; if (expr->ts.type == BT_CHARACTER) se->string_length = dest_word_len; *************** gfc_conv_associated (gfc_se *se, gfc_exp *** 2780,2785 **** --- 3001,3008 ---- tree tmp2; tree tmp; tree args, fndecl; + tree nonzero_charlen; + tree nonzero_arraylen; gfc_ss *ss1, *ss2; gfc_init_se (&arg1se, NULL); *************** gfc_conv_associated (gfc_se *se, gfc_exp *** 2801,2810 **** else { /* A pointer to an array. */ ! arg1se.descriptor_only = 1; ! gfc_conv_expr_lhs (&arg1se, arg1->expr); tmp2 = gfc_conv_descriptor_data_get (arg1se.expr); } tmp = build2 (NE_EXPR, boolean_type_node, tmp2, fold_convert (TREE_TYPE (tmp2), null_pointer_node)); se->expr = tmp; --- 3024,3034 ---- else { /* A pointer to an array. */ ! gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); tmp2 = gfc_conv_descriptor_data_get (arg1se.expr); } + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); tmp = build2 (NE_EXPR, boolean_type_node, tmp2, fold_convert (TREE_TYPE (tmp2), null_pointer_node)); se->expr = tmp; *************** gfc_conv_associated (gfc_se *se, gfc_exp *** 2813,2818 **** --- 3037,3049 ---- { /* An optional target. */ ss2 = gfc_walk_expr (arg2->expr); + + nonzero_charlen = NULL_TREE; + if (arg1->expr->ts.type == BT_CHARACTER) + nonzero_charlen = build2 (NE_EXPR, boolean_type_node, + arg1->expr->ts.cl->backend_decl, + integer_zero_node); + if (ss1 == gfc_ss_terminator) { /* A pointer to a scalar. */ *************** gfc_conv_associated (gfc_se *se, gfc_exp *** 2821,2837 **** --- 3052,3081 ---- gfc_conv_expr (&arg1se, arg1->expr); arg2se.want_pointer = 1; gfc_conv_expr (&arg2se, arg2->expr); + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr); se->expr = tmp; } else { + + /* An array pointer of zero length is not associated if target is + present. */ + arg1se.descriptor_only = 1; + gfc_conv_expr_lhs (&arg1se, arg1->expr); + tmp = gfc_conv_descriptor_stride (arg1se.expr, + gfc_rank_cst[arg1->expr->rank - 1]); + nonzero_arraylen = build2 (NE_EXPR, boolean_type_node, + tmp, integer_zero_node); + /* A pointer to an array, call library function _gfor_associated. */ gcc_assert (ss2 != gfc_ss_terminator); args = NULL_TREE; arg1se.want_pointer = 1; gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); args = gfc_chainon_list (args, arg1se.expr); + arg2se.want_pointer = 1; gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2); gfc_add_block_to_block (&se->pre, &arg2se.pre); *************** gfc_conv_associated (gfc_se *se, gfc_exp *** 2839,2846 **** args = gfc_chainon_list (args, arg2se.expr); fndecl = gfor_fndecl_associated; se->expr = gfc_build_function_call (fndecl, args); } ! } se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); } --- 3083,3100 ---- args = gfc_chainon_list (args, arg2se.expr); fndecl = gfor_fndecl_associated; se->expr = gfc_build_function_call (fndecl, args); + se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, + se->expr, nonzero_arraylen); + } ! ! /* If target is present zero character length pointers cannot ! be associated. */ ! if (nonzero_charlen != NULL_TREE) ! se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, ! se->expr, nonzero_charlen); ! } ! se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); } diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-io.c gcc-4.1.2/gcc/fortran/trans-io.c *** gcc-4.1.1/gcc/fortran/trans-io.c Tue Apr 18 16:07:13 2006 --- gcc-4.1.2/gcc/fortran/trans-io.c Mon Dec 25 22:53:29 2006 *************** set_string (stmtblock_t * block, stmtblo *** 518,524 **** { gfc_se se; tree tmp; - tree msg; tree io; tree len; gfc_st_parameter_field *p = &st_parameter_field[type]; --- 518,523 ---- *************** set_string (stmtblock_t * block, stmtblo *** 536,548 **** /* Integer variable assigned a format label. */ if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1) { gfc_conv_label_variable (&se, e); - msg = - gfc_build_cstring_const ("Assigned label is not a format label"); tmp = GFC_DECL_STRING_LEN (se.expr); tmp = build2 (LE_EXPR, boolean_type_node, tmp, convert (TREE_TYPE (tmp), integer_minus_one_node)); ! gfc_trans_runtime_check (tmp, msg, &se.pre); gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr))); gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); --- 535,552 ---- /* Integer variable assigned a format label. */ if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1) { + char * msg; + gfc_conv_label_variable (&se, e); tmp = GFC_DECL_STRING_LEN (se.expr); tmp = build2 (LE_EXPR, boolean_type_node, tmp, convert (TREE_TYPE (tmp), integer_minus_one_node)); ! ! asprintf(&msg, "Label assigned to variable '%s' is not a format label", ! e->symtree->name); ! gfc_trans_runtime_check (tmp, msg, &se.pre, &e->where); ! gfc_free (msg); ! gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr))); gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); *************** build_dt (tree function, gfc_code * code *** 1413,1419 **** dt->advance); if (dt->format_expr) ! mask |= set_string (&block, &post_block, var, IOPARM_dt_format, dt->format_expr); if (dt->format_label) --- 1417,1423 ---- dt->advance); if (dt->format_expr) ! mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format, dt->format_expr); if (dt->format_label) *************** transfer_expr (gfc_se * se, gfc_typespec *** 1696,1701 **** --- 1700,1706 ---- break; case BT_CHARACTER: + case BT_HOLLERITH: if (se->string_length) arg2 = se->string_length; else diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-stmt.c gcc-4.1.2/gcc/fortran/trans-stmt.c *** gcc-4.1.1/gcc/fortran/trans-stmt.c Sat Apr 8 17:05:52 2006 --- gcc-4.1.2/gcc/fortran/trans-stmt.c Mon Nov 6 17:18:03 2006 *************** Software Foundation, 51 Franklin Street, *** 30,35 **** --- 30,36 ---- #include "toplev.h" #include "real.h" #include "gfortran.h" + #include "flags.h" #include "trans.h" #include "trans-stmt.h" #include "trans-types.h" *************** gfc_trans_label_assign (gfc_code * code) *** 144,157 **** tree gfc_trans_goto (gfc_code * code) { tree assigned_goto; tree target; tree tmp; - tree assign_error; - tree range_error; gfc_se se; - if (code->label != NULL) return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); --- 145,156 ---- tree gfc_trans_goto (gfc_code * code) { + locus loc = code->loc; tree assigned_goto; tree target; tree tmp; gfc_se se; if (code->label != NULL) return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); *************** gfc_trans_goto (gfc_code * code) *** 159,169 **** gfc_init_se (&se, NULL); gfc_start_block (&se.pre); gfc_conv_label_variable (&se, code->expr); - assign_error = - gfc_build_cstring_const ("Assigned label is not a target label"); tmp = GFC_DECL_STRING_LEN (se.expr); tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node); ! gfc_trans_runtime_check (tmp, assign_error, &se.pre); assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); --- 158,167 ---- gfc_init_se (&se, NULL); gfc_start_block (&se.pre); gfc_conv_label_variable (&se, code->expr); tmp = GFC_DECL_STRING_LEN (se.expr); tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node); ! gfc_trans_runtime_check (tmp, "Assigned label is not a target label", ! &se.pre, &loc); assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); *************** gfc_trans_goto (gfc_code * code) *** 176,183 **** } /* Check the label list. */ - range_error = gfc_build_cstring_const ("Assigned label is not in the list"); - do { target = gfc_get_label_decl (code->label); --- 174,179 ---- *************** gfc_trans_goto (gfc_code * code) *** 190,196 **** code = code->block; } while (code != NULL); ! gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre); return gfc_finish_block (&se.pre); } --- 186,194 ---- code = code->block; } while (code != NULL); ! gfc_trans_runtime_check (boolean_true_node, ! "Assigned label is not in the list", &se.pre, &loc); ! return gfc_finish_block (&se.pre); } *************** gfc_trans_entry (gfc_code * code) *** 203,212 **** } /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree ! gfc_trans_call (gfc_code * code) { gfc_se se; gfc_ss * ss; --- 201,325 ---- } + /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of + elemental subroutines. Make temporaries for output arguments if any such + dependencies are found. Output arguments are chosen because internal_unpack + can be used, as is, to copy the result back to the variable. Notice that + this version is greatly reduced, compared with that in 4.2 because the + dependency improvements were not backported to 4.1. */ + static void + gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, + gfc_symbol * sym, gfc_actual_arglist * arg) + { + gfc_actual_arglist *arg0; + gfc_expr *e; + gfc_formal_arglist *formal; + gfc_loopinfo tmp_loop; + gfc_se parmse; + gfc_ss *ss; + gfc_ss_info *info; + gfc_symbol *fsym; + int n; + stmtblock_t block; + tree data; + tree offset; + tree size; + tree tmp; + + if (loopse->ss == NULL) + return; + + ss = loopse->ss; + arg0 = arg; + formal = sym->formal; + + /* Loop over all the arguments testing for dependencies. */ + for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) + { + e = arg->expr; + if (e == NULL) + continue; + + /* Obtain the info structure for the current argument. */ + info = NULL; + for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next) + { + if (ss->expr != e) + continue; + info = &ss->data.info; + break; + } + + /* If there is a dependency, create a temporary and use it + instead of the variable. */ + fsym = formal ? formal->sym : NULL; + if (e->expr_type == EXPR_VARIABLE + && e->rank && fsym + && fsym->attr.intent == INTENT_OUT + && arg->next->expr + && arg->next->expr->expr_type == EXPR_VARIABLE + && gfc_check_dependency (e, arg->next->expr, NULL, 0)) + { + /* Make a local loopinfo for the temporary creation, so that + none of the other ss->info's have to be renormalized. */ + gfc_init_loopinfo (&tmp_loop); + for (n = 0; n < info->dimen; n++) + { + tmp_loop.to[n] = loopse->loop->to[n]; + tmp_loop.from[n] = loopse->loop->from[n]; + tmp_loop.order[n] = loopse->loop->order[n]; + } + + /* Generate the temporary. Merge the block so that the + declarations are put at the right binding level. */ + size = gfc_create_var (gfc_array_index_type, NULL); + data = gfc_create_var (pvoid_type_node, NULL); + gfc_start_block (&block); + tmp = gfc_typenode_for_spec (&e->ts); + tmp = gfc_trans_allocate_temp_array (&se->pre, &se->post, + &tmp_loop, info, tmp, + false, true, false); + gfc_add_modify_expr (&se->pre, size, tmp); + tmp = fold_convert (pvoid_type_node, info->data); + gfc_add_modify_expr (&se->pre, data, tmp); + gfc_merge_block_scope (&block); + + /* Obtain the argument descriptor for unpacking. */ + gfc_init_se (&parmse, NULL); + parmse.want_pointer = 1; + gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e)); + gfc_add_block_to_block (&se->pre, &parmse.pre); + + /* Calculate the offset for the temporary. */ + offset = gfc_index_zero_node; + for (n = 0; n < info->dimen; n++) + { + tmp = gfc_conv_descriptor_stride (info->descriptor, + gfc_rank_cst[n]); + tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, + loopse->loop->from[n], tmp); + offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, + offset, tmp); + } + info->offset = gfc_create_var (gfc_array_index_type, NULL); + gfc_add_modify_expr (&se->pre, info->offset, offset); + + /* Copy the result back using unpack. */ + tmp = gfc_chainon_list (NULL_TREE, parmse.expr); + tmp = gfc_chainon_list (tmp, data); + tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp); + gfc_add_expr_to_block (&se->post, tmp); + + gfc_add_block_to_block (&se->post, &parmse.post); + } + } + } + + /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree ! gfc_trans_call (gfc_code * code, bool dependency_check) { gfc_se se; gfc_ss * ss; *************** gfc_trans_call (gfc_code * code) *** 273,283 **** gfc_conv_loop_setup (&loop); gfc_mark_ss_chain_used (ss, 1); /* Generate the loop body. */ gfc_start_scalarized_body (&loop, &body); gfc_init_block (&block); - gfc_copy_loopinfo_to_se (&loopse, &loop); - loopse.ss = ss; /* Add the subroutine call to the block. */ gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual); --- 386,410 ---- gfc_conv_loop_setup (&loop); gfc_mark_ss_chain_used (ss, 1); + /* Convert the arguments, checking for dependencies. */ + gfc_copy_loopinfo_to_se (&loopse, &loop); + loopse.ss = ss; + + /* For operator assignment, we need to do dependency checking. + We also check the intent of the parameters. */ + if (dependency_check) + { + gfc_symbol *sym; + sym = code->resolved_sym; + gcc_assert (sym->formal->sym->attr.intent = INTENT_OUT); + gcc_assert (sym->formal->next->sym->attr.intent = INTENT_IN); + gfc_conv_elemental_dependencies (&se, &loopse, sym, + code->ext.actual); + } + /* Generate the loop body. */ gfc_start_scalarized_body (&loop, &body); gfc_init_block (&block); /* Add the subroutine call to the block. */ gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual); *************** gfc_trans_call (gfc_code * code) *** 291,296 **** --- 418,424 ---- gfc_trans_scalarizing_loops (&loop, &body); gfc_add_block_to_block (&se.pre, &loop.pre); gfc_add_block_to_block (&se.pre, &loop.post); + gfc_add_block_to_block (&se.pre, &se.post); gfc_cleanup_loop (&loop); } *************** gfc_trans_arithmetic_if (gfc_code * code *** 543,548 **** --- 671,677 ---- /* Pre-evaluate COND. */ gfc_conv_expr_val (&se, code->expr); + se.expr = gfc_evaluate_now (se.expr, &se.pre); /* Build something to compare with. */ zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node); *************** static tree *** 1181,1186 **** --- 1310,1316 ---- gfc_trans_character_select (gfc_code *code) { tree init, node, end_label, tmp, type, args, *labels; + tree case_label; stmtblock_t block, body; gfc_case *cp, *d; gfc_code *c; *************** gfc_trans_character_select (gfc_code *co *** 1337,1346 **** gfc_add_block_to_block (&block, &se.pre); ! tmp = gfc_build_function_call (gfor_fndecl_select_string, args); ! tmp = build1 (GOTO_EXPR, void_type_node, tmp); ! gfc_add_expr_to_block (&block, tmp); tmp = gfc_finish_block (&body); gfc_add_expr_to_block (&block, tmp); tmp = build1_v (LABEL_EXPR, end_label); --- 1467,1481 ---- gfc_add_block_to_block (&block, &se.pre); ! tmp = build_function_call_expr (gfor_fndecl_select_string, args); ! case_label = gfc_create_var (TREE_TYPE (tmp), "case_label"); ! gfc_add_modify_expr (&block, case_label, tmp); + gfc_add_block_to_block (&block, &se.post); + + tmp = build1 (GOTO_EXPR, void_type_node, case_label); + gfc_add_expr_to_block (&block, tmp); + tmp = gfc_finish_block (&body); gfc_add_expr_to_block (&block, tmp); tmp = build1_v (LABEL_EXPR, end_label); *************** generate_loop_for_temp_to_lhs (gfc_expr *** 1668,1673 **** --- 1803,1809 ---- gfc_conv_expr (&lse, expr); /* Use the scalar assignment. */ + rse.string_length = lse.string_length; tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); /* Form the mask expression according to the mask tree list. */ *************** generate_loop_for_rhs_to_temp (gfc_expr *** 1765,1770 **** --- 1901,1907 ---- } /* Use the scalar assignment. */ + lse.string_length = rse.string_length; tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type); /* Form the mask expression according to the mask tree list. */ *************** compute_inner_temp_size (gfc_expr *expr1 *** 1835,1840 **** --- 1972,1978 ---- gfc_loopinfo loop; tree size; int i; + int save_flag; tree tmp; *lss = gfc_walk_expr (expr1); *************** compute_inner_temp_size (gfc_expr *expr1 *** 1867,1873 **** --- 2005,2014 ---- loop.array_parameter = 1; /* Calculate the bounds of the scalarization. */ + save_flag = flag_bounds_check; + flag_bounds_check = 0; gfc_conv_ss_startstride (&loop); + flag_bounds_check = save_flag; gfc_conv_loop_setup (&loop); /* Figure out how many elements we need. */ *************** gfc_trans_forall_1 (gfc_code * code, for *** 2558,2565 **** /* Explicit subroutine calls are prevented by the frontend but interface assignments can legitimately produce them. */ ! case EXEC_CALL: ! assign = gfc_trans_call (c); tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); gfc_add_expr_to_block (&block, tmp); break; --- 2699,2706 ---- /* Explicit subroutine calls are prevented by the frontend but interface assignments can legitimately produce them. */ ! case EXEC_ASSIGN_CALL: ! assign = gfc_trans_call (c, true); tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); gfc_add_expr_to_block (&block, tmp); break; diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-stmt.h gcc-4.1.2/gcc/fortran/trans-stmt.h *** gcc-4.1.1/gcc/fortran/trans-stmt.h Sun Aug 7 22:56:19 2005 --- gcc-4.1.2/gcc/fortran/trans-stmt.h Fri Nov 10 21:52:00 2006 *************** tree gfc_trans_code (gfc_code *); *** 28,33 **** --- 28,34 ---- /* trans-expr.c */ tree gfc_trans_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *); + tree gfc_trans_init_assign (gfc_code *); /* trans-stmt.c */ tree gfc_trans_cycle (gfc_code *); *************** tree gfc_trans_goto (gfc_code *); *** 38,44 **** tree gfc_trans_entry (gfc_code *); tree gfc_trans_pause (gfc_code *); tree gfc_trans_stop (gfc_code *); ! tree gfc_trans_call (gfc_code *); tree gfc_trans_return (gfc_code *); tree gfc_trans_if (gfc_code *); tree gfc_trans_arithmetic_if (gfc_code *); --- 39,45 ---- tree gfc_trans_entry (gfc_code *); tree gfc_trans_pause (gfc_code *); tree gfc_trans_stop (gfc_code *); ! tree gfc_trans_call (gfc_code *, bool); tree gfc_trans_return (gfc_code *); tree gfc_trans_if (gfc_code *); tree gfc_trans_arithmetic_if (gfc_code *); diff -Nrcpad gcc-4.1.1/gcc/fortran/trans-types.c gcc-4.1.2/gcc/fortran/trans-types.c *** gcc-4.1.1/gcc/fortran/trans-types.c Wed Jan 11 07:27:31 2006 --- gcc-4.1.2/gcc/fortran/trans-types.c Wed Dec 13 22:37:21 2006 *************** gfc_get_derived_type (gfc_symbol * deriv *** 1461,1479 **** } else { ! /* In a module, if an equal derived type is already available in the ! specification block, use its backend declaration and those of its ! components, rather than building anew so that potential dummy and ! actual arguments use the same TREE_TYPE. Non-module structures, ! need to be built, if found, because the order of visits to the ! namespaces is different. */ ! for (ns = derived->ns->parent; ns; ns = ns->parent) { for (dt = ns->derived_types; dt; dt = dt->next) { ! if (derived->module == NULL ! && dt->derived->backend_decl == NULL && gfc_compare_derived_types (dt->derived, derived)) gfc_get_derived_type (dt->derived); --- 1461,1487 ---- } else { ! /* If an equal derived type is already available in the parent namespace, ! use its backend declaration and those of its components, rather than ! building anew so that potential dummy and actual arguments use the ! same TREE_TYPE. If an equal type is found without a backend_decl, ! build the parent version and use it in the current namespace. */ ! if (derived->ns->parent) ! ns = derived->ns->parent; ! else if (derived->ns->proc_name ! && derived->ns->proc_name->ns != derived->ns) ! /* Derived types in an interface body obtain their parent reference ! through the proc_name symbol. */ ! ns = derived->ns->proc_name->ns; ! else ! /* Sometimes there isn't a parent reference! */ ! ns = NULL; ! for (; ns; ns = ns->parent) { for (dt = ns->derived_types; dt; dt = dt->next) { ! if (dt->derived->backend_decl == NULL && gfc_compare_derived_types (dt->derived, derived)) gfc_get_derived_type (dt->derived); *************** gfc_get_derived_type (gfc_symbol * deriv *** 1564,1573 **** other_equal_dts: /* Add this backend_decl to all the other, equal derived types and ! their components in this namespace. */ for (dt = derived->ns->derived_types; dt; dt = dt->next) copy_dt_decls_ifequal (derived, dt->derived); return derived->backend_decl; } --- 1572,1586 ---- other_equal_dts: /* Add this backend_decl to all the other, equal derived types and ! their components in this and sibling namespaces. */ ! for (dt = derived->ns->derived_types; dt; dt = dt->next) copy_dt_decls_ifequal (derived, dt->derived); + for (ns = derived->ns->sibling; ns; ns = ns->sibling) + for (dt = ns->derived_types; dt; dt = dt->next) + copy_dt_decls_ifequal (derived, dt->derived); + return derived->backend_decl; } diff -Nrcpad gcc-4.1.1/gcc/fortran/trans.c gcc-4.1.2/gcc/fortran/trans.c *** gcc-4.1.1/gcc/fortran/trans.c Tue Nov 1 21:40:06 2005 --- gcc-4.1.2/gcc/fortran/trans.c Fri Nov 10 21:52:00 2006 *************** Software Foundation, 51 Franklin Street, *** 45,50 **** --- 45,54 ---- static gfc_file *gfc_current_backend_file; + char gfc_msg_bounds[] = N_("Array bound mismatch"); + char gfc_msg_fault[] = N_("Array reference out of bounds"); + char gfc_msg_wrong_return[] = N_("Incorrect function return value"); + /* Advance along TREE_CHAIN n times. */ *************** gfc_build_function_call (tree fndecl, tr *** 335,346 **** /* Generate a runtime error if COND is true. */ void ! gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock) { stmtblock_t block; tree body; tree tmp; tree args; cond = fold (cond); --- 339,353 ---- /* Generate a runtime error if COND is true. */ void ! gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock, ! locus * where) { stmtblock_t block; tree body; tree tmp; tree args; + char * message; + int line; cond = fold (cond); *************** gfc_trans_runtime_check (tree cond, tree *** 350,368 **** /* The code to generate the error. */ gfc_start_block (&block); ! gcc_assert (TREE_CODE (msg) == STRING_CST); ! ! TREE_USED (msg) = 1; ! tmp = gfc_build_addr_expr (pchar_type_node, msg); args = gfc_chainon_list (NULL_TREE, tmp); - tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename); - args = gfc_chainon_list (args, tmp); - - tmp = build_int_cst (NULL_TREE, input_line); - args = gfc_chainon_list (args, tmp); - tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args); gfc_add_expr_to_block (&block, tmp); --- 357,380 ---- /* The code to generate the error. */ gfc_start_block (&block); ! if (where) ! { ! #ifdef USE_MAPPED_LOCATION ! line = LOCATION_LINE (where->lb->location); ! #else ! line = where->lb->linenum; ! #endif ! asprintf (&message, "%s (in file '%s', at line %d)", _(msgid), ! where->lb->file->filename, line); ! } ! else ! asprintf (&message, "%s (in file '%s', around line %d)", _(msgid), ! gfc_source_file, input_line + 1); ! tmp = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message)); ! gfc_free(message); args = gfc_chainon_list (NULL_TREE, tmp); tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args); gfc_add_expr_to_block (&block, tmp); *************** gfc_trans_code (gfc_code * code) *** 501,506 **** --- 513,522 ---- res = gfc_trans_pointer_assign (code); break; + case EXEC_INIT_ASSIGN: + res = gfc_trans_init_assign (code); + break; + case EXEC_CONTINUE: res = NULL_TREE; break; *************** gfc_trans_code (gfc_code * code) *** 530,536 **** break; case EXEC_CALL: ! res = gfc_trans_call (code); break; case EXEC_RETURN: --- 546,556 ---- break; case EXEC_CALL: ! res = gfc_trans_call (code, false); ! break; ! ! case EXEC_ASSIGN_CALL: ! res = gfc_trans_call (code, true); break; case EXEC_RETURN: diff -Nrcpad gcc-4.1.1/gcc/fortran/trans.h gcc-4.1.2/gcc/fortran/trans.h *** gcc-4.1.1/gcc/fortran/trans.h Mon May 8 05:01:56 2006 --- gcc-4.1.2/gcc/fortran/trans.h Wed Dec 13 22:37:21 2006 *************** void gfc_generate_constructors (void); *** 427,433 **** bool get_array_ctor_strlen (gfc_constructor *, tree *); /* Generate a runtime error check. */ ! void gfc_trans_runtime_check (tree, tree, stmtblock_t *); /* Generate code for an assignment, includes scalarization. */ tree gfc_trans_assignment (gfc_expr *, gfc_expr *); --- 427,433 ---- bool get_array_ctor_strlen (gfc_constructor *, tree *); /* Generate a runtime error check. */ ! void gfc_trans_runtime_check (tree, const char *, stmtblock_t *, locus *); /* Generate code for an assignment, includes scalarization. */ tree gfc_trans_assignment (gfc_expr *, gfc_expr *); *************** void gfc_finish_interface_mapping (gfc_i *** 665,668 **** --- 665,675 ---- void gfc_apply_interface_mapping (gfc_interface_mapping *, gfc_se *, gfc_expr *); + + /* Standard error messages used in all the trans-*.c files. */ + extern char gfc_msg_bounds[]; + extern char gfc_msg_fault[]; + extern char gfc_msg_wrong_return[]; + + #endif /* GFC_TRANS_H */ diff -Nrcpad gcc-4.1.1/libgfortran/ChangeLog gcc-4.1.2/libgfortran/ChangeLog *** gcc-4.1.1/libgfortran/ChangeLog Wed May 24 23:42:32 2006 --- gcc-4.1.2/libgfortran/ChangeLog Wed Feb 14 05:12:12 2007 *************** *** 1,3 **** --- 1,224 ---- + 2007-02-13 Release Manager + + * GCC 4.1.2 released. + + 2007-01-13 Jerry DeLisle + + PR libgfortran/30435 + * io/list_read.c (finish_separator): Don't call next_record. + (list_formatted_read_scalar): Clean up some comments and whitespace. + (nml_read_obj): Whitespace fix. + + 2006-12-25 Jerry DeLisle + + PR libfortran/30145 + * io/transfer.c (transfer_array): Check for negative extent. + + 2006-12-06 Francois-Xavier Coudert + + PR libfortran/29810 + * intrinsics/c99_functions.c (fmodf, fmodl, floorl): New functions. + * c99_protos.h (fmodf, fmodl, floorl): New prototypes. + * configure.ac: Check for fmodf, fmod and fmodl. + * configure: Regenerate. + * config.h.in: Regenerate. + * aclocal.m4: Regenerate with correct autoconf version (1.9.6). + * Makefile.in: Likewise. + + 2006-11-24 Jerry DeLisle + + PR libgfortran/29936 + * io/io.h (unit_flags): Add new flag has_recl. + * io.open.c (new_unit): Set flag if RECL= was specified. + * io/transfer.c (us_write): If flag set, leave recl as initialized by + new_unit. + + 2006-11-13 Francois-Xavier Coudert + + PR libfortran/27895 + * intrinsics/cshift0.c: Special cases for zero-sized arrays. + * intrinsics/pack_generic.c: Likewise. + * intrinsics/spread_generic.c: Likewise. + * intrinsics/reshape_generic.c (reshape_internal): Fix so that it + works correctly for zero-sized arrays. + * m4/reshape.m4: Likewise. + * generated/reshape_r16.c: Regenerate. + * generated/reshape_c4.c: Regenerate. + * generated/reshape_i4.c: Regenerate. + * generated/reshape_c16.c: Regenerate. + * generated/reshape_r10.c: Regenerate. + * generated/reshape_r8.c: Regenerate. + * generated/reshape_c10.c: Regenerate. + * generated/reshape_c8.c: Regenerate. + * generated/reshape_i8.c: Regenerate. + * generated/reshape_i16.c: Regenerate. + * generated/reshape_r4.c: Regenerate. + + 2006-11-04 Thomas Koenig + + PR libfortran/29627 + Backport from trunk + * libgfortran.h: Add ERROR_SHORT_RECORD + * runtime/error.c (translate_error): Add case + for ERROR_SHORT_RECORD. + * io/transfer.c (read_block_direct): Remove unneeded + tests for standard input, padding and formatted I/O. + If the record is short, read in as much data as possible, + then raise the error. + + 2006-10-27 Jerry DeLisle + + PR libgfortran/29563 + * io/io.h (st_parameter_dt): Add new flag at_eof. + * io/list_read.c (next_char): Set flag when EOF and return '\n' to + signal EOR. Check flag on next call and jump out. + * io/unit.c (get_internal_unit): Initialize new flag. + + 2006-10-02 Francois-Xavier Coudert + + PR libfortran/18791 + * m4/specific.m4: Special-case cabs so that its return type is + real. Special-case conjg so that their suffices are _4, _8, _10 and + _16 instead of _c4, _c8, _c10 and _c16. + * intrinsics/f2c_specifics.F90: Special-case conjg functions so + that their suffices are _4 and _8 instead of _c4 and _c8. + * generated/_conjg_c4.F90: Regenerate. + * generated/_conjg_c8.F90: Regenerate. + * generated/_conjg_c10.F90: Regenerate. + * generated/_conjg_c16.F90: Regenerate. + * generated/_abs_c4.F90: Regenerate. + * generated/_abs_c8.F90: Regenerate. + * generated/_abs_c10.F90: Regenerate. + * generated/_abs_c16.F90: Regenerate. + + 2006-09-29 Steven G. Kargl + + * intrinsics/cpu_time.c: Add cpu_time_10 and cpu_time_16 routines. + + 2006-09-10 Paul Thomas + + PR libfortran/28947 + * m4/matmul.m4: For the case where the second input argument is + transposed, ensure that the case with rank (a) == 1 is + correctly calculated. + * generated/matmul_r4.c: Regenerate. + * generated/matmul_r8.c: Regenerate. + * generated/matmul_r10.c: Regenerate. + * generated/matmul_r16.c: Regenerate. + * generated/matmul_c4.c: Regenerate. + * generated/matmul_c8.c: Regenerate. + * generated/matmul_c10.c: Regenerate. + * generated/matmul_c16.c: Regenerate. + * generated/matmul_i4.c: Regenerate. + * generated/matmul_i8.c: Regenerate. + * generated/matmul_i16.c: Regenerate. + + 2006-08-29 Paul Thomas + + PR libfortran/28005 + * m4/matmul.m4: Working part of function ported from + trunk. + * generated/matmul_r4.c: Regenerate. + * generated/matmul_r8.c: Regenerate. + * generated/matmul_r10.c: Regenerate. + * generated/matmul_r16.c: Regenerate. + * generated/matmul_c4.c: Regenerate. + * generated/matmul_c8.c: Regenerate. + * generated/matmul_c10.c: Regenerate. + * generated/matmul_c16.c: Regenerate. + * generated/matmul_i4.c: Regenerate. + * generated/matmul_i8.c: Regenerate. + * generated/matmul_i16.c: Regenerate. + + 2006-08-26 Thomas Koenig + + PR libfortran/28542 + * Makefile.am: Remove normalize.c. + * aclocal.m4: Regenerate. + * Makefile.in: Regenerate. + * libgfortran.h: #include . + Define GFC_REAL_*_DIGITS and GFC_REAL_*_RADIX. + Remove prototypes for normalize_r4_i4 and normalize_r8_i8. + * intrinsics/random.c (top level): Add prototypes for + random_r10, arandom_r10, random_r16 and arandom_r16. + (rnumber_4): New static function. + (rnumber_8): New static function. + (rnumber_10): New static function. + (rnumber_16): New static function. + (top level): Set to kiss_size to 12 if we have + REAL(KIND=16), to 8 otherwise. + Define KISS_DEFAULT_SEED_1, KISS_DEFAULT_SEED_2 and + KISS_DEFAULT_SEED_3. + (kiss_random_kernel): Take argument to differentiate + between different random number generators. + (random_r4): Add argument to call to kiss_random_kernel, + use rnumber_*. + (random_r8): Likewise. + (random_r10): New function. + (random_r16): New function. + (arandom_r4): Add argument to call to kiss_random_kernel, + use_rnumber_*. + (arandom_r8): Likewise. + (arandom_r10): New function. + (arandom_r16): New function. + * intrinsics/rand.c (rand): Use shift and mask. + * runtime/normalize.c: Remove. + + 2006-07-30 Jerry DeLisle + + PR libgfortran/28335 + * close.c (st_close): Revert error when UNIT does not exist. + Add comment to reference standard. + * file_position.c (st_flush): Improve error message. + Add comment to reference standard. + + 2006-07-28 Jerry DeLisle + + PR libgfortran/28339 + * io/transfer.c (next_record_w): Use next_array_record result to set + END_FILE. (write_block): Test for END_FILE before the next write occurs. + * io/unit.c (get_internal_unit): Initialize iunit->endfile for internal + unit. + + 2006-07-26 Jerry DeLisle + + PR libgfortran/28335 + * close.c (st_close): Add error when UNIT does not exist. + * file_position.c (st_flush): Add error when UNIT does not exist. + + 2006-07-26 Francois-Xavier Coudert + + * intrinsics/date_and_time.c (itime0,idate0,itime_i4,itime_i8, + idate_i4,idate_i8): New functions. + + 2006-07-02 Francois-Xavier Coudert + + PR fortran/28094 + * Makefile.am: Add _mod_r10.F90 and _mod_r16.F90. + * Makefile.in: Regenerate. + * generated/_mod_r10.F90: New file. + * generated/_mod_r16.F90: New file. + + 2006-06-20 Thomas Koenig + + PR libfortran/27784 + * intrinsics/string_intrinsics.c (compare_string): + Use memcmp instead of strncmp to avoid tripping over + CHAR(0) in a string. + + 2006-05-29 Jerry DeLisle + + PR libgfortran/27757 + * io/unix.c (fd_seek): Set active to zero. + + 2006-05-28 Jerry DeLisle + + PR libgfortran/24459 + * io/list_read.c (nml_parse_qualifier): Leave loop spec end value + at default value unless -std=f95 or if an array section + is specified in namelist input. Warn if -pedantic. + * io/io.h (st_parameter_dt): Add expanded_read flag. + 2006-05-24 Release Manager * GCC 4.1.1 released. diff -Nrcpad gcc-4.1.1/libgfortran/Makefile.am gcc-4.1.2/libgfortran/Makefile.am *** gcc-4.1.1/libgfortran/Makefile.am Sat Apr 22 07:13:20 2006 --- gcc-4.1.2/libgfortran/Makefile.am Sat Aug 26 19:17:35 2006 *************** intrinsics/umask.c \ *** 96,103 **** intrinsics/unlink.c \ intrinsics/unpack_generic.c \ runtime/in_pack_generic.c \ ! runtime/in_unpack_generic.c \ ! runtime/normalize.c gfor_src= \ runtime/compile_options.c \ --- 96,102 ---- intrinsics/unlink.c \ intrinsics/unpack_generic.c \ runtime/in_pack_generic.c \ ! runtime/in_unpack_generic.c gfor_src= \ runtime/compile_options.c \ *************** generated/_mod_i4.F90 \ *** 567,577 **** generated/_mod_i8.F90 \ generated/_mod_i16.F90 \ generated/_mod_r4.F90 \ ! generated/_mod_r8.F90 ! # There are commented out due to a bug in the way the front-end ! # handles MOD ! #generated/_mod_r10.F90 ! #generated/_mod_r16.F90 gfor_specific_src= \ $(gfor_built_specific_src) \ --- 566,574 ---- generated/_mod_i8.F90 \ generated/_mod_i16.F90 \ generated/_mod_r4.F90 \ ! generated/_mod_r8.F90 \ ! generated/_mod_r10.F90 \ ! generated/_mod_r16.F90 gfor_specific_src= \ $(gfor_built_specific_src) \ diff -Nrcpad gcc-4.1.1/libgfortran/Makefile.in gcc-4.1.2/libgfortran/Makefile.in *** gcc-4.1.1/libgfortran/Makefile.in Sat Apr 22 07:13:20 2006 --- gcc-4.1.2/libgfortran/Makefile.in Wed Dec 6 10:55:37 2006 *************** *** 1,8 **** ! # Makefile.in generated by automake 1.9.3 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, ! # 2003, 2004 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. --- 1,8 ---- ! # Makefile.in generated by automake 1.9.6 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, ! # 2003, 2004, 2005 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. *************** *** 14,21 **** @SET_MAKE@ - SOURCES = $(libgfortran_la_SOURCES) $(libgfortranbegin_la_SOURCES) - srcdir = @srcdir@ top_srcdir = @top_srcdir@ VPATH = @srcdir@ --- 14,19 ---- *************** DIST_COMMON = $(am__configure_deps) $(sr *** 47,53 **** $(top_srcdir)/configure ChangeLog subdir = . ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 ! am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ $(top_srcdir)/../config/acx.m4 \ $(top_srcdir)/../config/no-executables.m4 \ $(top_srcdir)/../libtool.m4 $(top_srcdir)/configure.ac --- 45,52 ---- $(top_srcdir)/configure ChangeLog subdir = . ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 ! am__aclocal_m4_deps = $(top_srcdir)/../config/lead-dot.m4 \ ! $(top_srcdir)/../config/stdint.m4 $(top_srcdir)/acinclude.m4 \ $(top_srcdir)/../config/acx.m4 \ $(top_srcdir)/../config/no-executables.m4 \ $(top_srcdir)/../libtool.m4 $(top_srcdir)/configure.ac *************** am__objects_33 = associated.lo abort.lo *** 179,185 **** selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \ system_clock.lo time.lo transpose_generic.lo tty.lo umask.lo \ unlink.lo unpack_generic.lo in_pack_generic.lo \ ! in_unpack_generic.lo normalize.lo am__objects_34 = am__objects_35 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ _abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \ --- 178,184 ---- selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \ system_clock.lo time.lo transpose_generic.lo tty.lo umask.lo \ unlink.lo unpack_generic.lo in_pack_generic.lo \ ! in_unpack_generic.lo am__objects_34 = am__objects_35 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \ _abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \ *************** am__objects_36 = _sign_i4.lo _sign_i8.lo *** 205,211 **** _sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \ _dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \ _atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \ ! _mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo am__objects_37 = $(am__objects_35) $(am__objects_36) dprod_r8.lo \ f2c_specifics.lo am_libgfortran_la_OBJECTS = $(am__objects_1) $(am__objects_31) \ --- 204,211 ---- _sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \ _dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \ _atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \ ! _mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \ ! _mod_r10.lo _mod_r16.lo am__objects_37 = $(am__objects_35) $(am__objects_36) dprod_r8.lo \ f2c_specifics.lo am_libgfortran_la_OBJECTS = $(am__objects_1) $(am__objects_31) \ *************** LTPPFCCOMPILE = $(LIBTOOL) --mode=compil *** 224,230 **** $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_FCFLAGS) $(FCFLAGS) FCLD = $(FC) ! FCLINK = $(LIBTOOL) --mode=link $(FCLD) $(AM_FFLAGS) $(FCFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) --- 224,230 ---- $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ $(AM_FCFLAGS) $(FCFLAGS) FCLD = $(FC) ! FCLINK = $(LIBTOOL) --mode=link $(FCLD) $(AM_FCFLAGS) $(FCFLAGS) \ $(AM_LDFLAGS) $(LDFLAGS) -o $@ COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) *************** intrinsics/umask.c \ *** 444,451 **** intrinsics/unlink.c \ intrinsics/unpack_generic.c \ runtime/in_pack_generic.c \ ! runtime/in_unpack_generic.c \ ! runtime/normalize.c gfor_src = \ runtime/compile_options.c \ --- 444,450 ---- intrinsics/unlink.c \ intrinsics/unpack_generic.c \ runtime/in_pack_generic.c \ ! runtime/in_unpack_generic.c gfor_src = \ runtime/compile_options.c \ *************** generated/_mod_i4.F90 \ *** 916,927 **** generated/_mod_i8.F90 \ generated/_mod_i16.F90 \ generated/_mod_r4.F90 \ ! generated/_mod_r8.F90 - # There are commented out due to a bug in the way the front-end - # handles MOD - #generated/_mod_r10.F90 - #generated/_mod_r16.F90 gfor_specific_src = \ $(gfor_built_specific_src) \ $(gfor_built_specific2_src) \ --- 915,924 ---- generated/_mod_i8.F90 \ generated/_mod_i16.F90 \ generated/_mod_r4.F90 \ ! generated/_mod_r8.F90 \ ! generated/_mod_r10.F90 \ ! generated/_mod_r16.F90 gfor_specific_src = \ $(gfor_built_specific_src) \ $(gfor_built_specific2_src) \ *************** _mod_r4.lo: generated/_mod_r4.F90 *** 1394,1399 **** --- 1391,1402 ---- _mod_r8.lo: generated/_mod_r8.F90 $(LIBTOOL) --mode=compile $(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_FCFLAGS) $(FCFLAGS) -c -o _mod_r8.lo `test -f 'generated/_mod_r8.F90' || echo '$(srcdir)/'`generated/_mod_r8.F90 + _mod_r10.lo: generated/_mod_r10.F90 + $(LIBTOOL) --mode=compile $(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_FCFLAGS) $(FCFLAGS) -c -o _mod_r10.lo `test -f 'generated/_mod_r10.F90' || echo '$(srcdir)/'`generated/_mod_r10.F90 + + _mod_r16.lo: generated/_mod_r16.F90 + $(LIBTOOL) --mode=compile $(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_FCFLAGS) $(FCFLAGS) -c -o _mod_r16.lo `test -f 'generated/_mod_r16.F90' || echo '$(srcdir)/'`generated/_mod_r16.F90 + f2c_specifics.lo: intrinsics/f2c_specifics.F90 $(LIBTOOL) --mode=compile $(FC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_FCFLAGS) $(FCFLAGS) -c -o f2c_specifics.lo `test -f 'intrinsics/f2c_specifics.F90' || echo '$(srcdir)/'`intrinsics/f2c_specifics.F90 *************** in_pack_generic.lo: runtime/in_pack_gene *** 2411,2419 **** in_unpack_generic.lo: runtime/in_unpack_generic.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o in_unpack_generic.lo `test -f 'runtime/in_unpack_generic.c' || echo '$(srcdir)/'`runtime/in_unpack_generic.c - normalize.lo: runtime/normalize.c - $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o normalize.lo `test -f 'runtime/normalize.c' || echo '$(srcdir)/'`runtime/normalize.c - .f90.o: $(FCCOMPILE) -c -o $@ $< --- 2414,2419 ---- diff -Nrcpad gcc-4.1.1/libgfortran/aclocal.m4 gcc-4.1.2/libgfortran/aclocal.m4 *** gcc-4.1.1/libgfortran/aclocal.m4 Sun Apr 16 21:15:36 2006 --- gcc-4.1.2/libgfortran/aclocal.m4 Wed Dec 6 10:55:37 2006 *************** *** 1,7 **** ! # generated automatically by aclocal 1.9.3 -*- Autoconf -*- ! # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ! # Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. --- 1,7 ---- ! # generated automatically by aclocal 1.9.6 -*- Autoconf -*- ! # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ! # 2005 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. *************** *** 11,33 **** # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. ! # -*- Autoconf -*- ! # Copyright (C) 2002, 2003 Free Software Foundation, Inc. ! # Generated from amversion.in; do not edit by hand. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA # AM_AUTOMAKE_VERSION(VERSION) # ---------------------------- --- 11,21 ---- # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. ! # Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc. ! # ! # This file is free software; the Free Software Foundation ! # gives unlimited permission to copy and/or distribute it, ! # with or without modifications, as long as this notice is preserved. # AM_AUTOMAKE_VERSION(VERSION) # ---------------------------- *************** AC_DEFUN([AM_AUTOMAKE_VERSION], [am__api *** 40,65 **** # Call AM_AUTOMAKE_VERSION so it can be traced. # This function is AC_REQUIREd by AC_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], ! [AM_AUTOMAKE_VERSION([1.9.3])]) ! ! # AM_AUX_DIR_EXPAND ! ! # Copyright (C) 2001, 2003 Free Software Foundation, Inc. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. # For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets # $ac_aux_dir to `$srcdir/foo'. In other projects, it is set to --- 28,42 ---- # Call AM_AUTOMAKE_VERSION so it can be traced. # This function is AC_REQUIREd by AC_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], ! [AM_AUTOMAKE_VERSION([1.9.6])]) ! # AM_AUX_DIR_EXPAND -*- Autoconf -*- ! # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. ! # ! # This file is free software; the Free Software Foundation ! # gives unlimited permission to copy and/or distribute it, ! # with or without modifications, as long as this notice is preserved. # For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets # $ac_aux_dir to `$srcdir/foo'. In other projects, it is set to *************** AC_PREREQ([2.50])dnl *** 106,131 **** am_aux_dir=`cd $ac_aux_dir && pwd` ]) ! # AM_CONDITIONAL -*- Autoconf -*- ! ! # Copyright (C) 1997, 2000, 2001, 2003, 2004 Free Software Foundation, Inc. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! # serial 6 # AM_CONDITIONAL(NAME, SHELL-CONDITION) # ------------------------------------- --- 83,98 ---- am_aux_dir=`cd $ac_aux_dir && pwd` ]) ! # AM_CONDITIONAL -*- Autoconf -*- ! # Copyright (C) 1997, 2000, 2001, 2003, 2004, 2005 ! # Free Software Foundation, Inc. ! # ! # This file is free software; the Free Software Foundation ! # gives unlimited permission to copy and/or distribute it, ! # with or without modifications, as long as this notice is preserved. ! # serial 7 # AM_CONDITIONAL(NAME, SHELL-CONDITION) # ------------------------------------- *************** AC_CONFIG_COMMANDS_PRE( *** 149,178 **** Usually this means the macro was only invoked conditionally.]]) fi])]) ! # Do all the work for Automake. -*- Autoconf -*- ! ! # This macro actually does too much some checks are only needed if ! # your package does certain things. But this isn't really a big deal. ! # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 # Free Software Foundation, Inc. ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! # serial 11 # AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) # AM_INIT_AUTOMAKE([OPTIONS]) --- 116,134 ---- Usually this means the macro was only invoked conditionally.]]) fi])]) ! # Do all the work for Automake. -*- Autoconf -*- ! # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 # Free Software Foundation, Inc. + # + # This file is free software; the Free Software Foundation + # gives unlimited permission to copy and/or distribute it, + # with or without modifications, as long as this notice is preserved. ! # serial 12 ! # This macro actually does too much. Some checks are only needed if ! # your package does certain things. But this isn't really a big deal. # AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) # AM_INIT_AUTOMAKE([OPTIONS]) *************** for _am_header in $config_headers :; do *** 274,360 **** done echo "timestamp for $1" >`AS_DIRNAME([$1])`/stamp-h[]$_am_stamp_count]) # AM_PROG_INSTALL_SH # ------------------ # Define $install_sh. - - # Copyright (C) 2001, 2003 Free Software Foundation, Inc. - - # This program is free software; you can redistribute it and/or modify - # it under the terms of the GNU General Public License as published by - # the Free Software Foundation; either version 2, or (at your option) - # any later version. - - # This program is distributed in the hope that it will be useful, - # but WITHOUT ANY WARRANTY; without even the implied warranty of - # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - # GNU General Public License for more details. - - # You should have received a copy of the GNU General Public License - # along with this program; if not, write to the Free Software - # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA - # 02111-1307, USA. - AC_DEFUN([AM_PROG_INSTALL_SH], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl install_sh=${install_sh-"$am_aux_dir/install-sh"} AC_SUBST(install_sh)]) ! # -*- Autoconf -*- ! # Copyright (C) 2003 Free Software Foundation, Inc. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! ! # serial 1 ! ! # Check whether the underlying file-system supports filenames ! # with a leading dot. For instance MS-DOS doesn't. ! AC_DEFUN([AM_SET_LEADING_DOT], ! [rm -rf .tst 2>/dev/null ! mkdir .tst 2>/dev/null ! if test -d .tst; then ! am__leading_dot=. ! else ! am__leading_dot=_ ! fi ! rmdir .tst 2>/dev/null ! AC_SUBST([am__leading_dot])]) ! ! # Add --enable-maintainer-mode option to configure. # From Jim Meyering ! # Copyright (C) 1996, 1998, 2000, 2001, 2002, 2003, 2004 # Free Software Foundation, Inc. ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! ! # serial 3 AC_DEFUN([AM_MAINTAINER_MODE], [AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles]) --- 230,260 ---- done echo "timestamp for $1" >`AS_DIRNAME([$1])`/stamp-h[]$_am_stamp_count]) + # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. + # + # This file is free software; the Free Software Foundation + # gives unlimited permission to copy and/or distribute it, + # with or without modifications, as long as this notice is preserved. + # AM_PROG_INSTALL_SH # ------------------ # Define $install_sh. AC_DEFUN([AM_PROG_INSTALL_SH], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl install_sh=${install_sh-"$am_aux_dir/install-sh"} AC_SUBST(install_sh)]) ! # Add --enable-maintainer-mode option to configure. -*- Autoconf -*- # From Jim Meyering ! # Copyright (C) 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005 # Free Software Foundation, Inc. + # + # This file is free software; the Free Software Foundation + # gives unlimited permission to copy and/or distribute it, + # with or without modifications, as long as this notice is preserved. ! # serial 4 AC_DEFUN([AM_MAINTAINER_MODE], [AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles]) *************** AC_DEFUN([AM_MAINTAINER_MODE], *** 373,399 **** AU_DEFUN([jm_MAINTAINER_MODE], [AM_MAINTAINER_MODE]) ! # -*- Autoconf -*- ! ! ! # Copyright (C) 1997, 1999, 2000, 2001, 2003 Free Software Foundation, Inc. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! # serial 3 # AM_MISSING_PROG(NAME, PROGRAM) # ------------------------------ --- 273,288 ---- AU_DEFUN([jm_MAINTAINER_MODE], [AM_MAINTAINER_MODE]) ! # Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- ! # Copyright (C) 1997, 1999, 2000, 2001, 2003, 2005 ! # Free Software Foundation, Inc. ! # ! # This file is free software; the Free Software Foundation ! # gives unlimited permission to copy and/or distribute it, ! # with or without modifications, as long as this notice is preserved. ! # serial 4 # AM_MISSING_PROG(NAME, PROGRAM) # ------------------------------ *************** else *** 419,445 **** fi ]) # AM_PROG_MKDIR_P # --------------- # Check whether `mkdir -p' is supported, fallback to mkinstalldirs otherwise. ! ! # Copyright (C) 2003, 2004 Free Software Foundation, Inc. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! # Automake 1.8 used `mkdir -m 0755 -p --' to ensure that directories # created by `make install' are always world readable, even if the # installer happens to have an overly restrictive umask (e.g. 077). --- 308,323 ---- fi ]) + # Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc. + # + # This file is free software; the Free Software Foundation + # gives unlimited permission to copy and/or distribute it, + # with or without modifications, as long as this notice is preserved. + # AM_PROG_MKDIR_P # --------------- # Check whether `mkdir -p' is supported, fallback to mkinstalldirs otherwise. ! # # Automake 1.8 used `mkdir -m 0755 -p --' to ensure that directories # created by `make install' are always world readable, even if the # installer happens to have an overly restrictive umask (e.g. 077). *************** else *** 493,517 **** fi AC_SUBST([mkdir_p])]) ! # Copyright (C) 1998, 1999, 2000, 2001, 2003, 2004 # Free Software Foundation, Inc. ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! ! # serial 4 # AM_ENABLE_MULTILIB([MAKEFILE], [REL-TO-TOP-SRCDIR]) # --------------------------------------------------- --- 371,384 ---- fi AC_SUBST([mkdir_p])]) ! # Copyright (C) 1998, 1999, 2000, 2001, 2003, 2004, 2005 # Free Software Foundation, Inc. + # + # This file is free software; the Free Software Foundation + # gives unlimited permission to copy and/or distribute it, + # with or without modifications, as long as this notice is preserved. ! # serial 5 # AM_ENABLE_MULTILIB([MAKEFILE], [REL-TO-TOP-SRCDIR]) # --------------------------------------------------- *************** multi_basedir="$multi_basedir" *** 562,587 **** CONFIG_SHELL=${CONFIG_SHELL-/bin/sh} CC="$CC"])])dnl ! # Helper functions for option handling. -*- Autoconf -*- ! ! # Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! # serial 2 # _AM_MANGLE_OPTION(NAME) # ----------------------- --- 429,443 ---- CONFIG_SHELL=${CONFIG_SHELL-/bin/sh} CC="$CC"])])dnl ! # Helper functions for option handling. -*- Autoconf -*- ! # Copyright (C) 2001, 2002, 2003, 2005 Free Software Foundation, Inc. ! # ! # This file is free software; the Free Software Foundation ! # gives unlimited permission to copy and/or distribute it, ! # with or without modifications, as long as this notice is preserved. ! # serial 3 # _AM_MANGLE_OPTION(NAME) # ----------------------- *************** AC_DEFUN([_AM_SET_OPTIONS], *** 606,633 **** AC_DEFUN([_AM_IF_OPTION], [m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) ! # ! # Check to make sure that the build environment is sane. ! # ! ! # Copyright (C) 1996, 1997, 2000, 2001, 2003 Free Software Foundation, Inc. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! # serial 3 # AM_SANITY_CHECK # --------------- --- 462,477 ---- AC_DEFUN([_AM_IF_OPTION], [m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) ! # Check to make sure that the build environment is sane. -*- Autoconf -*- ! # Copyright (C) 1996, 1997, 2000, 2001, 2003, 2005 ! # Free Software Foundation, Inc. ! # ! # This file is free software; the Free Software Foundation ! # gives unlimited permission to copy and/or distribute it, ! # with or without modifications, as long as this notice is preserved. ! # serial 4 # AM_SANITY_CHECK # --------------- *************** Check your system clock]) *** 670,694 **** fi AC_MSG_RESULT(yes)]) ! # AM_PROG_INSTALL_STRIP ! ! # Copyright (C) 2001, 2003 Free Software Foundation, Inc. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. # One issue with vendor `install' (even GNU) is that you can't # specify the program used to strip binaries. This is especially # annoying in cross-compiling environments, where the build's strip --- 514,527 ---- fi AC_MSG_RESULT(yes)]) ! # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. ! # ! # This file is free software; the Free Software Foundation ! # gives unlimited permission to copy and/or distribute it, ! # with or without modifications, as long as this notice is preserved. + # AM_PROG_INSTALL_STRIP + # --------------------- # One issue with vendor `install' (even GNU) is that you can't # specify the program used to strip binaries. This is especially # annoying in cross-compiling environments, where the build's strip *************** AC_SUBST([INSTALL_STRIP_PROGRAM])]) *** 711,735 **** # Check how to create a tarball. -*- Autoconf -*- ! # Copyright (C) 2004 Free Software Foundation, Inc. ! ! # This program is free software; you can redistribute it and/or modify ! # it under the terms of the GNU General Public License as published by ! # the Free Software Foundation; either version 2, or (at your option) ! # any later version. ! ! # This program is distributed in the hope that it will be useful, ! # but WITHOUT ANY WARRANTY; without even the implied warranty of ! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! # GNU General Public License for more details. ! ! # You should have received a copy of the GNU General Public License ! # along with this program; if not, write to the Free Software ! # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ! # 02111-1307, USA. ! ! # serial 1 # _AM_PROG_TAR(FORMAT) # -------------------- --- 544,556 ---- # Check how to create a tarball. -*- Autoconf -*- ! # Copyright (C) 2004, 2005 Free Software Foundation, Inc. ! # ! # This file is free software; the Free Software Foundation ! # gives unlimited permission to copy and/or distribute it, ! # with or without modifications, as long as this notice is preserved. + # serial 2 # _AM_PROG_TAR(FORMAT) # -------------------- *************** AC_SUBST([am__tar]) *** 817,820 **** --- 638,643 ---- AC_SUBST([am__untar]) ]) # _AM_PROG_TAR + m4_include([../config/lead-dot.m4]) + m4_include([../config/stdint.m4]) m4_include([acinclude.m4]) diff -Nrcpad gcc-4.1.1/libgfortran/c99_protos.h gcc-4.1.2/libgfortran/c99_protos.h *** gcc-4.1.1/libgfortran/c99_protos.h Wed Oct 19 09:45:27 2005 --- gcc-4.1.2/libgfortran/c99_protos.h Wed Dec 6 10:55:37 2006 *************** extern float fabsf(float); *** 100,105 **** --- 100,120 ---- extern float floorf(float); #endif + #ifndef HAVE_FLOORL + #define HAVE_FLOORL 1 + extern long double floorl (long double x); + #endif + + #ifndef HAVE_FMODF + #define HAVE_FMODF 1 + extern float fmodf (float x, float y); + #endif + + #ifndef HAVE_FMODL + #define HAVE_FMODL 1 + extern long double fmodl (long double x, long double y); + #endif + #ifndef HAVE_FREXPF #define HAVE_FREXPF 1 extern float frexpf(float, int *); diff -Nrcpad gcc-4.1.1/libgfortran/config.h.in gcc-4.1.2/libgfortran/config.h.in *** gcc-4.1.1/libgfortran/config.h.in Wed Jan 11 18:55:18 2006 --- gcc-4.1.2/libgfortran/config.h.in Wed Dec 6 10:55:37 2006 *************** *** 318,323 **** --- 318,332 ---- /* libm includes floorl */ #undef HAVE_FLOORL + /* libm includes fmod */ + #undef HAVE_FMOD + + /* libm includes fmodf */ + #undef HAVE_FMODF + + /* libm includes fmodl */ + #undef HAVE_FMODL + /* Define if you have fpsetmask. */ #undef HAVE_FPSETMASK *************** *** 678,683 **** --- 687,707 ---- /* Define to the version of this package. */ #undef PACKAGE_VERSION + /* The size of a `char', as computed by sizeof. */ + #undef SIZEOF_CHAR + + /* The size of a `int', as computed by sizeof. */ + #undef SIZEOF_INT + + /* The size of a `long', as computed by sizeof. */ + #undef SIZEOF_LONG + + /* The size of a `short', as computed by sizeof. */ + #undef SIZEOF_SHORT + + /* The size of a `void *', as computed by sizeof. */ + #undef SIZEOF_VOID_P + /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS diff -Nrcpad gcc-4.1.1/libgfortran/configure gcc-4.1.2/libgfortran/configure *** gcc-4.1.1/libgfortran/configure Wed May 24 23:46:15 2006 --- gcc-4.1.2/libgfortran/configure Wed Dec 6 10:55:37 2006 *************** _ACEOF *** 15077,15082 **** --- 15077,15313 ---- fi + echo "$as_me:$LINENO: checking for fmodf in -lm" >&5 + echo $ECHO_N "checking for fmodf in -lm... $ECHO_C" >&6 + if test "${ac_cv_lib_m_fmodf+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + ac_check_lib_save_LIBS=$LIBS + LIBS="-lm $LIBS" + if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 + echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } + fi + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + /* Override any gcc2 internal prototype to avoid an error. */ + #ifdef __cplusplus + extern "C" + #endif + /* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ + char fmodf (); + int + main () + { + fmodf (); + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext conftest$ac_exeext + if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_fmodf=yes + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_lib_m_fmodf=no + fi + rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + LIBS=$ac_check_lib_save_LIBS + fi + echo "$as_me:$LINENO: result: $ac_cv_lib_m_fmodf" >&5 + echo "${ECHO_T}$ac_cv_lib_m_fmodf" >&6 + if test $ac_cv_lib_m_fmodf = yes; then + + cat >>confdefs.h <<\_ACEOF + #define HAVE_FMODF 1 + _ACEOF + + fi + + echo "$as_me:$LINENO: checking for fmod in -lm" >&5 + echo $ECHO_N "checking for fmod in -lm... $ECHO_C" >&6 + if test "${ac_cv_lib_m_fmod+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + ac_check_lib_save_LIBS=$LIBS + LIBS="-lm $LIBS" + if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 + echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } + fi + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + /* Override any gcc2 internal prototype to avoid an error. */ + #ifdef __cplusplus + extern "C" + #endif + /* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ + char fmod (); + int + main () + { + fmod (); + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext conftest$ac_exeext + if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_fmod=yes + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_lib_m_fmod=no + fi + rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + LIBS=$ac_check_lib_save_LIBS + fi + echo "$as_me:$LINENO: result: $ac_cv_lib_m_fmod" >&5 + echo "${ECHO_T}$ac_cv_lib_m_fmod" >&6 + if test $ac_cv_lib_m_fmod = yes; then + + cat >>confdefs.h <<\_ACEOF + #define HAVE_FMOD 1 + _ACEOF + + fi + + echo "$as_me:$LINENO: checking for fmodl in -lm" >&5 + echo $ECHO_N "checking for fmodl in -lm... $ECHO_C" >&6 + if test "${ac_cv_lib_m_fmodl+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + ac_check_lib_save_LIBS=$LIBS + LIBS="-lm $LIBS" + if test x$gcc_no_link = xyes; then + { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5 + echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;} + { (exit 1); exit 1; }; } + fi + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + /* Override any gcc2 internal prototype to avoid an error. */ + #ifdef __cplusplus + extern "C" + #endif + /* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ + char fmodl (); + int + main () + { + fmodl (); + ; + return 0; + } + _ACEOF + rm -f conftest.$ac_objext conftest$ac_exeext + if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_lib_m_fmodl=yes + else + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_lib_m_fmodl=no + fi + rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + LIBS=$ac_check_lib_save_LIBS + fi + echo "$as_me:$LINENO: result: $ac_cv_lib_m_fmodl" >&5 + echo "${ECHO_T}$ac_cv_lib_m_fmodl" >&6 + if test $ac_cv_lib_m_fmodl = yes; then + + cat >>confdefs.h <<\_ACEOF + #define HAVE_FMODL 1 + _ACEOF + + fi + echo "$as_me:$LINENO: checking for frexpf in -lm" >&5 echo $ECHO_N "checking for frexpf in -lm... $ECHO_C" >&6 if test "${ac_cv_lib_m_frexpf+set}" = set; then diff -Nrcpad gcc-4.1.1/libgfortran/configure.ac gcc-4.1.2/libgfortran/configure.ac *** gcc-4.1.1/libgfortran/configure.ac Sun Feb 19 19:46:54 2006 --- gcc-4.1.2/libgfortran/configure.ac Wed Dec 6 10:55:37 2006 *************** AC_CHECK_LIB([m],[cabsl],[AC_DEFINE([HAV *** 238,243 **** --- 238,246 ---- AC_CHECK_LIB([m],[floorf],[AC_DEFINE([HAVE_FLOORF],[1],[libm includes floorf])]) AC_CHECK_LIB([m],[floor],[AC_DEFINE([HAVE_FLOOR],[1],[libm includes floor])]) AC_CHECK_LIB([m],[floorl],[AC_DEFINE([HAVE_FLOORL],[1],[libm includes floorl])]) + AC_CHECK_LIB([m],[fmodf],[AC_DEFINE([HAVE_FMODF],[1],[libm includes fmodf])]) + AC_CHECK_LIB([m],[fmod],[AC_DEFINE([HAVE_FMOD],[1],[libm includes fmod])]) + AC_CHECK_LIB([m],[fmodl],[AC_DEFINE([HAVE_FMODL],[1],[libm includes fmodl])]) AC_CHECK_LIB([m],[frexpf],[AC_DEFINE([HAVE_FREXPF],[1],[libm includes frexpf])]) AC_CHECK_LIB([m],[frexp],[AC_DEFINE([HAVE_FREXP],[1],[libm includes frexp])]) AC_CHECK_LIB([m],[frexpl],[AC_DEFINE([HAVE_FREXPL],[1],[libm includes frexpl])]) diff -Nrcpad gcc-4.1.1/libgfortran/generated/_abs_c10.F90 gcc-4.1.2/libgfortran/generated/_abs_c10.F90 *** gcc-4.1.1/libgfortran/generated/_abs_c10.F90 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/_abs_c10.F90 Mon Oct 2 09:37:09 2006 *************** *** 42,48 **** elemental function specific__abs_c10 (parm) complex (kind=10), intent (in) :: parm ! complex (kind=10) :: specific__abs_c10 specific__abs_c10 = abs (parm) end function --- 42,48 ---- elemental function specific__abs_c10 (parm) complex (kind=10), intent (in) :: parm ! real (kind=10) :: specific__abs_c10 specific__abs_c10 = abs (parm) end function diff -Nrcpad gcc-4.1.1/libgfortran/generated/_abs_c16.F90 gcc-4.1.2/libgfortran/generated/_abs_c16.F90 *** gcc-4.1.1/libgfortran/generated/_abs_c16.F90 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/_abs_c16.F90 Mon Oct 2 09:37:09 2006 *************** *** 42,48 **** elemental function specific__abs_c16 (parm) complex (kind=16), intent (in) :: parm ! complex (kind=16) :: specific__abs_c16 specific__abs_c16 = abs (parm) end function --- 42,48 ---- elemental function specific__abs_c16 (parm) complex (kind=16), intent (in) :: parm ! real (kind=16) :: specific__abs_c16 specific__abs_c16 = abs (parm) end function diff -Nrcpad gcc-4.1.1/libgfortran/generated/_abs_c4.F90 gcc-4.1.2/libgfortran/generated/_abs_c4.F90 *** gcc-4.1.1/libgfortran/generated/_abs_c4.F90 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/_abs_c4.F90 Mon Oct 2 09:37:09 2006 *************** *** 42,48 **** elemental function specific__abs_c4 (parm) complex (kind=4), intent (in) :: parm ! complex (kind=4) :: specific__abs_c4 specific__abs_c4 = abs (parm) end function --- 42,48 ---- elemental function specific__abs_c4 (parm) complex (kind=4), intent (in) :: parm ! real (kind=4) :: specific__abs_c4 specific__abs_c4 = abs (parm) end function diff -Nrcpad gcc-4.1.1/libgfortran/generated/_abs_c8.F90 gcc-4.1.2/libgfortran/generated/_abs_c8.F90 *** gcc-4.1.1/libgfortran/generated/_abs_c8.F90 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/_abs_c8.F90 Mon Oct 2 09:37:09 2006 *************** *** 42,48 **** elemental function specific__abs_c8 (parm) complex (kind=8), intent (in) :: parm ! complex (kind=8) :: specific__abs_c8 specific__abs_c8 = abs (parm) end function --- 42,48 ---- elemental function specific__abs_c8 (parm) complex (kind=8), intent (in) :: parm ! real (kind=8) :: specific__abs_c8 specific__abs_c8 = abs (parm) end function diff -Nrcpad gcc-4.1.1/libgfortran/generated/_conjg_c10.F90 gcc-4.1.2/libgfortran/generated/_conjg_c10.F90 *** gcc-4.1.1/libgfortran/generated/_conjg_c10.F90 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/_conjg_c10.F90 Mon Oct 2 09:37:09 2006 *************** *** 40,50 **** #if defined (HAVE_GFC_COMPLEX_10) ! elemental function specific__conjg_c10 (parm) complex (kind=10), intent (in) :: parm ! complex (kind=10) :: specific__conjg_c10 ! specific__conjg_c10 = conjg (parm) end function --- 40,50 ---- #if defined (HAVE_GFC_COMPLEX_10) ! elemental function specific__conjg_10 (parm) complex (kind=10), intent (in) :: parm ! complex (kind=10) :: specific__conjg_10 ! specific__conjg_10 = conjg (parm) end function diff -Nrcpad gcc-4.1.1/libgfortran/generated/_conjg_c16.F90 gcc-4.1.2/libgfortran/generated/_conjg_c16.F90 *** gcc-4.1.1/libgfortran/generated/_conjg_c16.F90 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/_conjg_c16.F90 Mon Oct 2 09:37:09 2006 *************** *** 40,50 **** #if defined (HAVE_GFC_COMPLEX_16) ! elemental function specific__conjg_c16 (parm) complex (kind=16), intent (in) :: parm ! complex (kind=16) :: specific__conjg_c16 ! specific__conjg_c16 = conjg (parm) end function --- 40,50 ---- #if defined (HAVE_GFC_COMPLEX_16) ! elemental function specific__conjg_16 (parm) complex (kind=16), intent (in) :: parm ! complex (kind=16) :: specific__conjg_16 ! specific__conjg_16 = conjg (parm) end function diff -Nrcpad gcc-4.1.1/libgfortran/generated/_conjg_c4.F90 gcc-4.1.2/libgfortran/generated/_conjg_c4.F90 *** gcc-4.1.1/libgfortran/generated/_conjg_c4.F90 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/_conjg_c4.F90 Mon Oct 2 09:37:09 2006 *************** *** 40,50 **** #if defined (HAVE_GFC_COMPLEX_4) ! elemental function specific__conjg_c4 (parm) complex (kind=4), intent (in) :: parm ! complex (kind=4) :: specific__conjg_c4 ! specific__conjg_c4 = conjg (parm) end function --- 40,50 ---- #if defined (HAVE_GFC_COMPLEX_4) ! elemental function specific__conjg_4 (parm) complex (kind=4), intent (in) :: parm ! complex (kind=4) :: specific__conjg_4 ! specific__conjg_4 = conjg (parm) end function diff -Nrcpad gcc-4.1.1/libgfortran/generated/_conjg_c8.F90 gcc-4.1.2/libgfortran/generated/_conjg_c8.F90 *** gcc-4.1.1/libgfortran/generated/_conjg_c8.F90 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/_conjg_c8.F90 Mon Oct 2 09:37:09 2006 *************** *** 40,50 **** #if defined (HAVE_GFC_COMPLEX_8) ! elemental function specific__conjg_c8 (parm) complex (kind=8), intent (in) :: parm ! complex (kind=8) :: specific__conjg_c8 ! specific__conjg_c8 = conjg (parm) end function --- 40,50 ---- #if defined (HAVE_GFC_COMPLEX_8) ! elemental function specific__conjg_8 (parm) complex (kind=8), intent (in) :: parm ! complex (kind=8) :: specific__conjg_8 ! specific__conjg_8 = conjg (parm) end function diff -Nrcpad gcc-4.1.1/libgfortran/generated/_mod_r10.F90 gcc-4.1.2/libgfortran/generated/_mod_r10.F90 *** gcc-4.1.1/libgfortran/generated/_mod_r10.F90 Thu Jan 1 00:00:00 1970 --- gcc-4.1.2/libgfortran/generated/_mod_r10.F90 Sun Jul 2 21:17:05 2006 *************** *** 0 **** --- 1,51 ---- + ! Copyright 2002 Free Software Foundation, Inc. + ! Contributed by Paul Brook + ! + !This file is part of the GNU Fortran 95 runtime library (libgfortran). + ! + !GNU libgfortran is free software; you can redistribute it and/or + !modify it under the terms of the GNU General Public + !License as published by the Free Software Foundation; either + !version 2 of the License, or (at your option) any later version. + + !In addition to the permissions in the GNU General Public License, the + !Free Software Foundation gives you unlimited permission to link the + !compiled version of this file into combinations with other programs, + !and to distribute those combinations without any restriction coming + !from the use of this file. (The General Public License restrictions + !do apply in other respects; for example, they cover modification of + !the file, and distribution when not linked into a combine + !executable.) + ! + !GNU libgfortran is distributed in the hope that it will be useful, + !but WITHOUT ANY WARRANTY; without even the implied warranty of + !MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + !GNU General Public License for more details. + ! + !You should have received a copy of the GNU General Public + !License along with libgfortran; see the file COPYING. If not, + !write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + !Boston, MA 02110-1301, USA. + ! + !This file is machine generated. + + + + #include "config.h" + #include "kinds.inc" + #include "c99_protos.inc" + + #if defined (HAVE_GFC_REAL_10) + + + + elemental function specific__mod_r10 (p1, p2) + real (kind=10), intent (in) :: p1, p2 + real (kind=10) :: specific__mod_r10 + + specific__mod_r10 = mod (p1, p2) + end function + + + + #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/_mod_r16.F90 gcc-4.1.2/libgfortran/generated/_mod_r16.F90 *** gcc-4.1.1/libgfortran/generated/_mod_r16.F90 Thu Jan 1 00:00:00 1970 --- gcc-4.1.2/libgfortran/generated/_mod_r16.F90 Sun Jul 2 21:17:05 2006 *************** *** 0 **** --- 1,51 ---- + ! Copyright 2002 Free Software Foundation, Inc. + ! Contributed by Paul Brook + ! + !This file is part of the GNU Fortran 95 runtime library (libgfortran). + ! + !GNU libgfortran is free software; you can redistribute it and/or + !modify it under the terms of the GNU General Public + !License as published by the Free Software Foundation; either + !version 2 of the License, or (at your option) any later version. + + !In addition to the permissions in the GNU General Public License, the + !Free Software Foundation gives you unlimited permission to link the + !compiled version of this file into combinations with other programs, + !and to distribute those combinations without any restriction coming + !from the use of this file. (The General Public License restrictions + !do apply in other respects; for example, they cover modification of + !the file, and distribution when not linked into a combine + !executable.) + ! + !GNU libgfortran is distributed in the hope that it will be useful, + !but WITHOUT ANY WARRANTY; without even the implied warranty of + !MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + !GNU General Public License for more details. + ! + !You should have received a copy of the GNU General Public + !License along with libgfortran; see the file COPYING. If not, + !write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + !Boston, MA 02110-1301, USA. + ! + !This file is machine generated. + + + + #include "config.h" + #include "kinds.inc" + #include "c99_protos.inc" + + #if defined (HAVE_GFC_REAL_16) + + + + elemental function specific__mod_r16 (p1, p2) + real (kind=16), intent (in) :: p1, p2 + real (kind=16) :: specific__mod_r16 + + specific__mod_r16 = mod (p1, p2) + end function + + + + #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_c10.c gcc-4.1.2/libgfortran/generated/matmul_c10.c *** gcc-4.1.1/libgfortran/generated/matmul_c10.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_c10.c Sun Sep 10 17:26:54 2006 *************** matmul_c10 (gfc_array_c10 * const restri *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_COMPLEX_10 *restrict abase_x; ! const GFC_COMPLEX_10 *restrict bbase_y; ! GFC_COMPLEX_10 *restrict dest_y; ! GFC_COMPLEX_10 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_COMPLEX_10) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_COMPLEX_10 *restrict bbase_y; ! GFC_COMPLEX_10 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_COMPLEX_10) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_c10 (gfc_array_c10 * const restri *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_COMPLEX_10 *restrict bbase_y; + GFC_COMPLEX_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_10) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_COMPLEX_10 *restrict abase_x; + const GFC_COMPLEX_10 *restrict bbase_y; + GFC_COMPLEX_10 *restrict dest_y; + GFC_COMPLEX_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_10) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_c16.c gcc-4.1.2/libgfortran/generated/matmul_c16.c *** gcc-4.1.1/libgfortran/generated/matmul_c16.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_c16.c Sun Sep 10 17:26:54 2006 *************** matmul_c16 (gfc_array_c16 * const restri *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_COMPLEX_16 *restrict abase_x; ! const GFC_COMPLEX_16 *restrict bbase_y; ! GFC_COMPLEX_16 *restrict dest_y; ! GFC_COMPLEX_16 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_COMPLEX_16) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_COMPLEX_16 *restrict bbase_y; ! GFC_COMPLEX_16 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_COMPLEX_16) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_c16 (gfc_array_c16 * const restri *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_COMPLEX_16 *restrict bbase_y; + GFC_COMPLEX_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_16) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_COMPLEX_16 *restrict abase_x; + const GFC_COMPLEX_16 *restrict bbase_y; + GFC_COMPLEX_16 *restrict dest_y; + GFC_COMPLEX_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_c4.c gcc-4.1.2/libgfortran/generated/matmul_c4.c *** gcc-4.1.1/libgfortran/generated/matmul_c4.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_c4.c Sun Sep 10 17:26:54 2006 *************** matmul_c4 (gfc_array_c4 * const restrict *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_COMPLEX_4 *restrict abase_x; ! const GFC_COMPLEX_4 *restrict bbase_y; ! GFC_COMPLEX_4 *restrict dest_y; ! GFC_COMPLEX_4 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_COMPLEX_4) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_COMPLEX_4 *restrict bbase_y; ! GFC_COMPLEX_4 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_COMPLEX_4) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_c4 (gfc_array_c4 * const restrict *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_COMPLEX_4 *restrict bbase_y; + GFC_COMPLEX_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_4) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_COMPLEX_4 *restrict abase_x; + const GFC_COMPLEX_4 *restrict bbase_y; + GFC_COMPLEX_4 *restrict dest_y; + GFC_COMPLEX_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_c8.c gcc-4.1.2/libgfortran/generated/matmul_c8.c *** gcc-4.1.1/libgfortran/generated/matmul_c8.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_c8.c Sun Sep 10 17:26:54 2006 *************** matmul_c8 (gfc_array_c8 * const restrict *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_COMPLEX_8 *restrict abase_x; ! const GFC_COMPLEX_8 *restrict bbase_y; ! GFC_COMPLEX_8 *restrict dest_y; ! GFC_COMPLEX_8 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_COMPLEX_8) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_COMPLEX_8 *restrict bbase_y; ! GFC_COMPLEX_8 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_COMPLEX_8) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_c8 (gfc_array_c8 * const restrict *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_COMPLEX_8 *restrict bbase_y; + GFC_COMPLEX_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_8) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_COMPLEX_8 *restrict abase_x; + const GFC_COMPLEX_8 *restrict bbase_y; + GFC_COMPLEX_8 *restrict dest_y; + GFC_COMPLEX_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_i16.c gcc-4.1.2/libgfortran/generated/matmul_i16.c *** gcc-4.1.1/libgfortran/generated/matmul_i16.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_i16.c Sun Sep 10 17:26:54 2006 *************** matmul_i16 (gfc_array_i16 * const restri *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_INTEGER_16 *restrict abase_x; ! const GFC_INTEGER_16 *restrict bbase_y; ! GFC_INTEGER_16 *restrict dest_y; ! GFC_INTEGER_16 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_INTEGER_16) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_INTEGER_16 *restrict bbase_y; ! GFC_INTEGER_16 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_INTEGER_16) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_i16 (gfc_array_i16 * const restri *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_INTEGER_16 *restrict bbase_y; + GFC_INTEGER_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_16) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_INTEGER_16 *restrict abase_x; + const GFC_INTEGER_16 *restrict bbase_y; + GFC_INTEGER_16 *restrict dest_y; + GFC_INTEGER_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_i4.c gcc-4.1.2/libgfortran/generated/matmul_i4.c *** gcc-4.1.1/libgfortran/generated/matmul_i4.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_i4.c Sun Sep 10 17:26:54 2006 *************** matmul_i4 (gfc_array_i4 * const restrict *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_INTEGER_4 *restrict abase_x; ! const GFC_INTEGER_4 *restrict bbase_y; ! GFC_INTEGER_4 *restrict dest_y; ! GFC_INTEGER_4 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_INTEGER_4) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_INTEGER_4 *restrict bbase_y; ! GFC_INTEGER_4 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_INTEGER_4) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_i4 (gfc_array_i4 * const restrict *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_INTEGER_4 *restrict bbase_y; + GFC_INTEGER_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_4) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_INTEGER_4 *restrict abase_x; + const GFC_INTEGER_4 *restrict bbase_y; + GFC_INTEGER_4 *restrict dest_y; + GFC_INTEGER_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_i8.c gcc-4.1.2/libgfortran/generated/matmul_i8.c *** gcc-4.1.1/libgfortran/generated/matmul_i8.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_i8.c Sun Sep 10 17:26:54 2006 *************** matmul_i8 (gfc_array_i8 * const restrict *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_INTEGER_8 *restrict abase_x; ! const GFC_INTEGER_8 *restrict bbase_y; ! GFC_INTEGER_8 *restrict dest_y; ! GFC_INTEGER_8 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_INTEGER_8) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_INTEGER_8 *restrict bbase_y; ! GFC_INTEGER_8 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_INTEGER_8) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_i8 (gfc_array_i8 * const restrict *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_INTEGER_8 *restrict bbase_y; + GFC_INTEGER_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_8) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_INTEGER_8 *restrict abase_x; + const GFC_INTEGER_8 *restrict bbase_y; + GFC_INTEGER_8 *restrict dest_y; + GFC_INTEGER_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_r10.c gcc-4.1.2/libgfortran/generated/matmul_r10.c *** gcc-4.1.1/libgfortran/generated/matmul_r10.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_r10.c Sun Sep 10 17:26:54 2006 *************** matmul_r10 (gfc_array_r10 * const restri *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_REAL_10 *restrict abase_x; ! const GFC_REAL_10 *restrict bbase_y; ! GFC_REAL_10 *restrict dest_y; ! GFC_REAL_10 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_REAL_10) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_REAL_10 *restrict bbase_y; ! GFC_REAL_10 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_REAL_10) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_r10 (gfc_array_r10 * const restri *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_REAL_10 *restrict bbase_y; + GFC_REAL_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_10) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_REAL_10 *restrict abase_x; + const GFC_REAL_10 *restrict bbase_y; + GFC_REAL_10 *restrict dest_y; + GFC_REAL_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_10) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_r16.c gcc-4.1.2/libgfortran/generated/matmul_r16.c *** gcc-4.1.1/libgfortran/generated/matmul_r16.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_r16.c Sun Sep 10 17:26:54 2006 *************** matmul_r16 (gfc_array_r16 * const restri *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_REAL_16 *restrict abase_x; ! const GFC_REAL_16 *restrict bbase_y; ! GFC_REAL_16 *restrict dest_y; ! GFC_REAL_16 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_REAL_16) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_REAL_16 *restrict bbase_y; ! GFC_REAL_16 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_REAL_16) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_r16 (gfc_array_r16 * const restri *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_REAL_16 *restrict bbase_y; + GFC_REAL_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_16) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_REAL_16 *restrict abase_x; + const GFC_REAL_16 *restrict bbase_y; + GFC_REAL_16 *restrict dest_y; + GFC_REAL_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_r4.c gcc-4.1.2/libgfortran/generated/matmul_r4.c *** gcc-4.1.1/libgfortran/generated/matmul_r4.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_r4.c Sun Sep 10 17:26:54 2006 *************** matmul_r4 (gfc_array_r4 * const restrict *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_REAL_4 *restrict abase_x; ! const GFC_REAL_4 *restrict bbase_y; ! GFC_REAL_4 *restrict dest_y; ! GFC_REAL_4 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_REAL_4) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_REAL_4 *restrict bbase_y; ! GFC_REAL_4 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_REAL_4) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_r4 (gfc_array_r4 * const restrict *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_REAL_4 *restrict bbase_y; + GFC_REAL_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_4) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_REAL_4 *restrict abase_x; + const GFC_REAL_4 *restrict bbase_y; + GFC_REAL_4 *restrict dest_y; + GFC_REAL_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/matmul_r8.c gcc-4.1.2/libgfortran/generated/matmul_r8.c *** gcc-4.1.1/libgfortran/generated/matmul_r8.c Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/generated/matmul_r8.c Sun Sep 10 17:26:54 2006 *************** matmul_r8 (gfc_array_r8 * const restrict *** 204,210 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 204,248 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const GFC_REAL_8 *restrict abase_x; ! const GFC_REAL_8 *restrict bbase_y; ! GFC_REAL_8 *restrict dest_y; ! GFC_REAL_8 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (GFC_REAL_8) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const GFC_REAL_8 *restrict bbase_y; ! GFC_REAL_8 s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (GFC_REAL_8) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** matmul_r8 (gfc_array_r8 * const restrict *** 216,221 **** --- 254,294 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_REAL_8 *restrict bbase_y; + GFC_REAL_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_8) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_REAL_8 *restrict abase_x; + const GFC_REAL_8 *restrict bbase_y; + GFC_REAL_8 *restrict dest_y; + GFC_REAL_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/generated/reshape_c10.c gcc-4.1.2/libgfortran/generated/reshape_c10.c *** gcc-4.1.1/libgfortran/generated/reshape_c10.c Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/reshape_c10.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,44 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ extern void reshape_c10 (gfc_array_c10 *, gfc_array_c10 *, shape_type *, gfc_array_c10 *, shape_type *); --- 37,42 ---- *************** reshape_c10 (gfc_array_c10 * ret, gfc_ar *** 77,82 **** --- 75,81 ---- const GFC_COMPLEX_10 *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_c10 (gfc_array_c10 * ret, gfc_ar *** 91,97 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 90,96 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_c10 (gfc_array_c10 * ret, gfc_ar *** 135,147 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 134,150 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_c10 (gfc_array_c10 * ret, gfc_ar *** 153,165 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 156,173 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_c10 (gfc_array_c10 * ret, gfc_ar *** 171,176 **** --- 179,185 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_c10 (gfc_array_c10 * ret, gfc_ar *** 188,193 **** --- 197,220 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (GFC_COMPLEX_10); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_c10 (gfc_array_c10 * ret, gfc_ar *** 197,202 **** --- 224,230 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/generated/reshape_c16.c gcc-4.1.2/libgfortran/generated/reshape_c16.c *** gcc-4.1.1/libgfortran/generated/reshape_c16.c Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/reshape_c16.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,44 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ extern void reshape_c16 (gfc_array_c16 *, gfc_array_c16 *, shape_type *, gfc_array_c16 *, shape_type *); --- 37,42 ---- *************** reshape_c16 (gfc_array_c16 * ret, gfc_ar *** 77,82 **** --- 75,81 ---- const GFC_COMPLEX_16 *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_c16 (gfc_array_c16 * ret, gfc_ar *** 91,97 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 90,96 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_c16 (gfc_array_c16 * ret, gfc_ar *** 135,147 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 134,150 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_c16 (gfc_array_c16 * ret, gfc_ar *** 153,165 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 156,173 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_c16 (gfc_array_c16 * ret, gfc_ar *** 171,176 **** --- 179,185 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_c16 (gfc_array_c16 * ret, gfc_ar *** 188,193 **** --- 197,220 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (GFC_COMPLEX_16); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_c16 (gfc_array_c16 * ret, gfc_ar *** 197,202 **** --- 224,230 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/generated/reshape_c4.c gcc-4.1.2/libgfortran/generated/reshape_c4.c *** gcc-4.1.1/libgfortran/generated/reshape_c4.c Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/reshape_c4.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,44 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ extern void reshape_c4 (gfc_array_c4 *, gfc_array_c4 *, shape_type *, gfc_array_c4 *, shape_type *); --- 37,42 ---- *************** reshape_c4 (gfc_array_c4 * ret, gfc_arra *** 77,82 **** --- 75,81 ---- const GFC_COMPLEX_4 *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_c4 (gfc_array_c4 * ret, gfc_arra *** 91,97 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 90,96 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_c4 (gfc_array_c4 * ret, gfc_arra *** 135,147 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 134,150 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_c4 (gfc_array_c4 * ret, gfc_arra *** 153,165 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 156,173 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_c4 (gfc_array_c4 * ret, gfc_arra *** 171,176 **** --- 179,185 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_c4 (gfc_array_c4 * ret, gfc_arra *** 188,193 **** --- 197,220 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (GFC_COMPLEX_4); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_c4 (gfc_array_c4 * ret, gfc_arra *** 197,202 **** --- 224,230 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/generated/reshape_c8.c gcc-4.1.2/libgfortran/generated/reshape_c8.c *** gcc-4.1.1/libgfortran/generated/reshape_c8.c Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/reshape_c8.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,44 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ extern void reshape_c8 (gfc_array_c8 *, gfc_array_c8 *, shape_type *, gfc_array_c8 *, shape_type *); --- 37,42 ---- *************** reshape_c8 (gfc_array_c8 * ret, gfc_arra *** 77,82 **** --- 75,81 ---- const GFC_COMPLEX_8 *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_c8 (gfc_array_c8 * ret, gfc_arra *** 91,97 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 90,96 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_c8 (gfc_array_c8 * ret, gfc_arra *** 135,147 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 134,150 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_c8 (gfc_array_c8 * ret, gfc_arra *** 153,165 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 156,173 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_c8 (gfc_array_c8 * ret, gfc_arra *** 171,176 **** --- 179,185 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_c8 (gfc_array_c8 * ret, gfc_arra *** 188,193 **** --- 197,220 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (GFC_COMPLEX_8); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_c8 (gfc_array_c8 * ret, gfc_arra *** 197,202 **** --- 224,230 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/generated/reshape_i16.c gcc-4.1.2/libgfortran/generated/reshape_i16.c *** gcc-4.1.1/libgfortran/generated/reshape_i16.c Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/reshape_i16.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,44 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ extern void reshape_16 (gfc_array_i16 *, gfc_array_i16 *, shape_type *, gfc_array_i16 *, shape_type *); --- 37,42 ---- *************** reshape_16 (gfc_array_i16 * ret, gfc_arr *** 77,82 **** --- 75,81 ---- const GFC_INTEGER_16 *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_16 (gfc_array_i16 * ret, gfc_arr *** 91,97 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 90,96 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_16 (gfc_array_i16 * ret, gfc_arr *** 135,147 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 134,150 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_16 (gfc_array_i16 * ret, gfc_arr *** 153,165 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 156,173 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_16 (gfc_array_i16 * ret, gfc_arr *** 171,176 **** --- 179,185 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_16 (gfc_array_i16 * ret, gfc_arr *** 188,193 **** --- 197,220 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (GFC_INTEGER_16); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_16 (gfc_array_i16 * ret, gfc_arr *** 197,202 **** --- 224,230 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/generated/reshape_i4.c gcc-4.1.2/libgfortran/generated/reshape_i4.c *** gcc-4.1.1/libgfortran/generated/reshape_i4.c Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/reshape_i4.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,44 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ extern void reshape_4 (gfc_array_i4 *, gfc_array_i4 *, shape_type *, gfc_array_i4 *, shape_type *); --- 37,42 ---- *************** reshape_4 (gfc_array_i4 * ret, gfc_array *** 77,82 **** --- 75,81 ---- const GFC_INTEGER_4 *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_4 (gfc_array_i4 * ret, gfc_array *** 91,97 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 90,96 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_4 (gfc_array_i4 * ret, gfc_array *** 135,147 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 134,150 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_4 (gfc_array_i4 * ret, gfc_array *** 153,165 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 156,173 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_4 (gfc_array_i4 * ret, gfc_array *** 171,176 **** --- 179,185 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_4 (gfc_array_i4 * ret, gfc_array *** 188,193 **** --- 197,220 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (GFC_INTEGER_4); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_4 (gfc_array_i4 * ret, gfc_array *** 197,202 **** --- 224,230 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/generated/reshape_i8.c gcc-4.1.2/libgfortran/generated/reshape_i8.c *** gcc-4.1.1/libgfortran/generated/reshape_i8.c Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/generated/reshape_i8.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,44 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ extern void reshape_8 (gfc_array_i8 *, gfc_array_i8 *, shape_type *, gfc_array_i8 *, shape_type *); --- 37,42 ---- *************** reshape_8 (gfc_array_i8 * ret, gfc_array *** 77,82 **** --- 75,81 ---- const GFC_INTEGER_8 *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_8 (gfc_array_i8 * ret, gfc_array *** 91,97 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 90,96 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_8 (gfc_array_i8 * ret, gfc_array *** 135,147 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 134,150 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_8 (gfc_array_i8 * ret, gfc_array *** 153,165 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 156,173 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_8 (gfc_array_i8 * ret, gfc_array *** 171,176 **** --- 179,185 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_8 (gfc_array_i8 * ret, gfc_array *** 188,193 **** --- 197,220 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (GFC_INTEGER_8); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_8 (gfc_array_i8 * ret, gfc_array *** 197,202 **** --- 224,230 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/generated/reshape_r10.c gcc-4.1.2/libgfortran/generated/reshape_r10.c *** gcc-4.1.1/libgfortran/generated/reshape_r10.c Sun Apr 16 21:15:36 2006 --- gcc-4.1.2/libgfortran/generated/reshape_r10.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,44 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ extern void reshape_r10 (gfc_array_r10 * const restrict, gfc_array_r10 * const restrict, --- 37,42 ---- *************** reshape_r10 (gfc_array_r10 * const restr *** 83,88 **** --- 81,87 ---- const GFC_REAL_10 *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_r10 (gfc_array_r10 * const restr *** 97,103 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 96,102 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_r10 (gfc_array_r10 * const restr *** 141,153 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 140,156 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_r10 (gfc_array_r10 * const restr *** 159,171 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 162,179 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_r10 (gfc_array_r10 * const restr *** 177,182 **** --- 185,191 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_r10 (gfc_array_r10 * const restr *** 194,199 **** --- 203,226 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (GFC_REAL_10); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_r10 (gfc_array_r10 * const restr *** 203,208 **** --- 230,236 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/generated/reshape_r16.c gcc-4.1.2/libgfortran/generated/reshape_r16.c *** gcc-4.1.1/libgfortran/generated/reshape_r16.c Sat Apr 22 07:13:20 2006 --- gcc-4.1.2/libgfortran/generated/reshape_r16.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,44 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ extern void reshape_r16 (gfc_array_r16 * const restrict, gfc_array_r16 * const restrict, --- 37,42 ---- *************** reshape_r16 (gfc_array_r16 * const restr *** 83,88 **** --- 81,87 ---- const GFC_REAL_16 *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_r16 (gfc_array_r16 * const restr *** 97,103 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 96,102 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_r16 (gfc_array_r16 * const restr *** 141,153 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 140,156 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_r16 (gfc_array_r16 * const restr *** 159,171 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 162,179 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_r16 (gfc_array_r16 * const restr *** 177,182 **** --- 185,191 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_r16 (gfc_array_r16 * const restr *** 194,199 **** --- 203,226 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (GFC_REAL_16); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_r16 (gfc_array_r16 * const restr *** 203,208 **** --- 230,236 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/c99_functions.c gcc-4.1.2/libgfortran/intrinsics/c99_functions.c *** gcc-4.1.1/libgfortran/intrinsics/c99_functions.c Tue Feb 7 17:35:25 2006 --- gcc-4.1.2/libgfortran/intrinsics/c99_functions.c Wed Dec 6 10:55:37 2006 *************** floorf(float x) *** 176,181 **** --- 176,190 ---- } #endif + #ifndef HAVE_FMODF + #define HAVE_FMODF 1 + float + fmodf (float x, float y) + { + return (float) fmod (x, y); + } + #endif + #ifndef HAVE_FREXPF #define HAVE_FREXPF 1 float *************** log10l(long double x) *** 474,479 **** --- 483,529 ---- #endif + #ifndef HAVE_FLOORL + #define HAVE_FLOORL 1 + long double + floorl (long double x) + { + /* Zero, possibly signed. */ + if (x == 0) + return x; + + /* Large magnitude. */ + if (x > DBL_MAX || x < (-DBL_MAX)) + return x; + + /* Small positive values. */ + if (x >= 0 && x < DBL_MIN) + return 0; + + /* Small negative values. */ + if (x < 0 && x > (-DBL_MIN)) + return -1; + + return floor (x); + } + #endif + + + #ifndef HAVE_FMODL + #define HAVE_FMODL 1 + long double + fmodl (long double x, long double y) + { + if (y == 0.0L) + return 0.0L; + + /* Need to check that the result has the same sign as x and magnitude + less than the magnitude of y. */ + return x - floorl (x / y) * y; + } + #endif + + #if !defined(HAVE_CABSF) #define HAVE_CABSF 1 float diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/cpu_time.c gcc-4.1.2/libgfortran/intrinsics/cpu_time.c *** gcc-4.1.1/libgfortran/intrinsics/cpu_time.c Sat Sep 24 08:39:35 2005 --- gcc-4.1.2/libgfortran/intrinsics/cpu_time.c Fri Sep 29 23:38:08 2006 *************** void cpu_time_8 (GFC_REAL_8 *time) *** 171,176 **** --- 171,200 ---- *time = sec + usec * (GFC_REAL_8)1.e-6; } + #ifdef HAVE_GFC_REAL_10 + extern void cpu_time_10 (GFC_REAL_10 *); + export_proto(cpu_time_10); + + void cpu_time_10 (GFC_REAL_10 *time) + { + long sec, usec; + __cpu_time_1 (&sec, &usec); + *time = sec + usec * (GFC_REAL_10)1.e-6; + } + #endif + + #ifdef HAVE_GFC_REAL_16 + extern void cpu_time_16 (GFC_REAL_16 *); + export_proto(cpu_time_16); + + void cpu_time_16 (GFC_REAL_16 *time) + { + long sec, usec; + __cpu_time_1 (&sec, &usec); + *time = sec + usec * (GFC_REAL_16)1.e-6; + } + #endif + extern void second_sub (GFC_REAL_4 *); export_proto(second_sub); diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/cshift0.c gcc-4.1.2/libgfortran/intrinsics/cshift0.c *** gcc-4.1.1/libgfortran/intrinsics/cshift0.c Tue Sep 13 07:15:01 2005 --- gcc-4.1.2/libgfortran/intrinsics/cshift0.c Tue Nov 14 06:19:04 2006 *************** *** 1,5 **** /* Generic implementation of the CSHIFT intrinsic ! Copyright 2003, 2005 Free Software Foundation, Inc. Contributed by Feng Wang This file is part of the GNU Fortran 95 runtime library (libgfortran). --- 1,5 ---- /* Generic implementation of the CSHIFT intrinsic ! Copyright 2003, 2005, 2006 Free Software Foundation, Inc. Contributed by Feng Wang This file is part of the GNU Fortran 95 runtime library (libgfortran). *************** cshift0 (gfc_array_char * ret, const gfc *** 144,151 **** if (ret->data == NULL) { int i; - ret->data = internal_malloc_size (size * size0 ((array_t *)array)); ret->offset = 0; ret->dtype = array->dtype; for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) --- 144,151 ---- if (ret->data == NULL) { int i; + index_type arraysize = size0 ((array_t *)array); ret->offset = 0; ret->dtype = array->dtype; for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) *************** cshift0 (gfc_array_char * ret, const gfc *** 156,163 **** if (i == 0) ret->dim[i].stride = 1; else ! ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; } } for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) --- 156,172 ---- if (i == 0) ret->dim[i].stride = 1; else ! ret->dim[i].stride = (ret->dim[i-1].ubound + 1) ! * ret->dim[i-1].stride; } + + if (arraysize > 0) + ret->data = internal_malloc_size (size * arraysize); + else + { + ret->data = internal_malloc_size (1); + return; + } } for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/date_and_time.c gcc-4.1.2/libgfortran/intrinsics/date_and_time.c *** gcc-4.1.1/libgfortran/intrinsics/date_and_time.c Tue Nov 1 05:53:29 2005 --- gcc-4.1.2/libgfortran/intrinsics/date_and_time.c Wed Jul 26 09:44:59 2006 *************** *** 1,5 **** /* Implementation of the DATE_AND_TIME intrinsic. ! Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc. Contributed by Steven Bosscher. This file is part of the GNU Fortran 95 runtime library (libgfortran). --- 1,5 ---- /* Implementation of the DATE_AND_TIME intrinsic. ! Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Steven Bosscher. This file is part of the GNU Fortran 95 runtime library (libgfortran). *************** Boston, MA 02110-1301, USA. */ *** 84,90 **** ZONE (optional) shall be scalar and of type default character, and shall be of length at least 5 in order to contain the complete value. It is an INTENT(OUT) argument. Its leftmost 5 characters ! are assigned a value of the form ħhhmm, where hh and mm are the time difference with respect to Coordinated Universal Time (UTC) in hours and parts of an hour expressed in minutes, respectively. If there is no clock available, they are assigned blanks. --- 84,90 ---- ZONE (optional) shall be scalar and of type default character, and shall be of length at least 5 in order to contain the complete value. It is an INTENT(OUT) argument. Its leftmost 5 characters ! are assigned a value of the form [+-]hhmm, where hh and mm are the time difference with respect to Coordinated Universal Time (UTC) in hours and parts of an hour expressed in minutes, respectively. If there is no clock available, they are assigned blanks. *************** secnds (GFC_REAL_4 *x) *** 359,361 **** --- 359,523 ---- temp2 = (temp1 - temp2 > 0.0) ? temp2 : (temp2 - 86400.0); return temp1 - temp2; } + + + + /* ITIME(X) - Non-standard + + Description: Returns the current local time hour, minutes, and seconds + in elements 1, 2, and 3 of X, respectively. */ + + static void + itime0 (int x[3]) + { + #ifndef HAVE_NO_DATE_TIME + time_t lt; + struct tm local_time; + + lt = time (NULL); + + if (lt != (time_t) -1) + { + local_time = *localtime (<); + + x[0] = local_time.tm_hour; + x[1] = local_time.tm_min; + x[2] = local_time.tm_sec; + } + #else + x[0] = x[1] = x[2] = -1; + #endif + } + + extern void itime_i4 (gfc_array_i4 *); + export_proto(itime_i4); + + void + itime_i4 (gfc_array_i4 *__values) + { + int x[3], i; + size_t len, delta; + GFC_INTEGER_4 *vptr; + + /* Call helper function. */ + itime0(x); + + /* Copy the value into the array. */ + len = __values->dim[0].ubound + 1 - __values->dim[0].lbound; + assert (len >= 3); + delta = __values->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = __values->data; + for (i = 0; i < 3; i++, vptr += delta) + *vptr = x[i]; + } + + + extern void itime_i8 (gfc_array_i8 *); + export_proto(itime_i8); + + void + itime_i8 (gfc_array_i8 *__values) + { + int x[3], i; + size_t len, delta; + GFC_INTEGER_8 *vptr; + + /* Call helper function. */ + itime0(x); + + /* Copy the value into the array. */ + len = __values->dim[0].ubound + 1 - __values->dim[0].lbound; + assert (len >= 3); + delta = __values->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = __values->data; + for (i = 0; i < 3; i++, vptr += delta) + *vptr = x[i]; + } + + + + /* IDATE(X) - Non-standard + + Description: Fills TArray with the numerical values at the current + local time. The day (in the range 1-31), month (in the range 1-12), + and year appear in elements 1, 2, and 3 of X, respectively. + The year has four significant digits. */ + + static void + idate0 (int x[3]) + { + #ifndef HAVE_NO_DATE_TIME + time_t lt; + struct tm local_time; + + lt = time (NULL); + + if (lt != (time_t) -1) + { + local_time = *localtime (<); + + x[0] = local_time.tm_mday; + x[1] = 1 + local_time.tm_mon; + x[2] = 1900 + local_time.tm_year; + } + #else + x[0] = x[1] = x[2] = -1; + #endif + } + + extern void idate_i4 (gfc_array_i4 *); + export_proto(idate_i4); + + void + idate_i4 (gfc_array_i4 *__values) + { + int x[3], i; + size_t len, delta; + GFC_INTEGER_4 *vptr; + + /* Call helper function. */ + idate0(x); + + /* Copy the value into the array. */ + len = __values->dim[0].ubound + 1 - __values->dim[0].lbound; + assert (len >= 3); + delta = __values->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = __values->data; + for (i = 0; i < 3; i++, vptr += delta) + *vptr = x[i]; + } + + + extern void idate_i8 (gfc_array_i8 *); + export_proto(idate_i8); + + void + idate_i8 (gfc_array_i8 *__values) + { + int x[3], i; + size_t len, delta; + GFC_INTEGER_8 *vptr; + + /* Call helper function. */ + idate0(x); + + /* Copy the value into the array. */ + len = __values->dim[0].ubound + 1 - __values->dim[0].lbound; + assert (len >= 3); + delta = __values->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = __values->data; + for (i = 0; i < 3; i++, vptr += delta) + *vptr = x[i]; + } diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/f2c_specifics.F90 gcc-4.1.2/libgfortran/intrinsics/f2c_specifics.F90 *** gcc-4.1.1/libgfortran/intrinsics/f2c_specifics.F90 Wed Aug 17 02:49:08 2005 --- gcc-4.1.2/libgfortran/intrinsics/f2c_specifics.F90 Mon Oct 2 09:37:09 2006 *************** REAL_BODY(cosh) *** 135,145 **** REAL_HEAD(tanh) REAL_BODY(tanh) - COMPLEX_HEAD(conjg) - COMPLEX_BODY(conjg) - DCOMPLEX_HEAD(conjg) - DCOMPLEX_BODY(conjg) - REAL_HEAD(aint) REAL_BODY(aint) --- 135,140 ---- *************** REAL2_BODY(atan2) *** 167,169 **** --- 162,177 ---- REAL2_HEAD(mod) REAL2_BODY(mod) + + ! conjg is special-cased because it is not suffixed _c4 but _4 + subroutine f2c_specific__conjg_4 (res, parm) + COMPLEX, intent (in) :: parm + COMPLEX, intent (out) :: res + res = conjg (parm) + end subroutine + subroutine f2c_specific__conjg_8 (res, parm) + DOUBLE COMPLEX, intent (in) :: parm + DOUBLE COMPLEX, intent (out) :: res + res = conjg (parm) + end subroutine + diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/pack_generic.c gcc-4.1.2/libgfortran/intrinsics/pack_generic.c *** gcc-4.1.1/libgfortran/intrinsics/pack_generic.c Tue Sep 13 07:15:01 2005 --- gcc-4.1.2/libgfortran/intrinsics/pack_generic.c Tue Nov 14 06:19:04 2006 *************** *** 1,5 **** /* Generic implementation of the PACK intrinsic ! Copyright (C) 2002, 2004, 2005 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). --- 1,5 ---- /* Generic implementation of the PACK intrinsic ! Copyright (C) 2002, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of the GNU Fortran 95 runtime library (libgfortran). *************** pack_internal (gfc_array_char *ret, cons *** 195,206 **** ret->dim[0].ubound = total - 1; ret->dim[0].stride = 1; - ret->data = internal_malloc_size (size * total); ret->offset = 0; - if (total == 0) ! /* In this case, nothing remains to be done. */ ! return; } rstride0 = ret->dim[0].stride * size; --- 195,209 ---- ret->dim[0].ubound = total - 1; ret->dim[0].stride = 1; ret->offset = 0; if (total == 0) ! { ! /* In this case, nothing remains to be done. */ ! ret->data = internal_malloc_size (1); ! return; ! } ! else ! ret->data = internal_malloc_size (size * total); } rstride0 = ret->dim[0].stride * size; *************** pack_internal (gfc_array_char *ret, cons *** 210,216 **** mstride0 = mstride[0]; rptr = ret->data; ! while (sptr) { /* Test this element. */ if (*mptr) --- 213,219 ---- mstride0 = mstride[0]; rptr = ret->data; ! while (sptr && mptr) { /* Test this element. */ if (*mptr) *************** pack_s_internal (gfc_array_char *ret, co *** 315,328 **** --- 318,334 ---- index_type extent[GFC_MAX_DIMENSIONS]; index_type n; index_type dim; + index_type ssize; index_type nelem; dim = GFC_DESCRIPTOR_RANK (array); + ssize = 1; for (n = 0; n < dim; n++) { count[n] = 0; extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; sstride[n] = array->dim[n].stride * size; + ssize *= extent[n]; } if (sstride[0] == 0) sstride[0] = size; *************** pack_s_internal (gfc_array_char *ret, co *** 352,376 **** total *= extent[n]; } else ! { ! /* The result array will be empty. */ ! ret->dim[0].lbound = 0; ! ret->dim[0].ubound = -1; ! ret->dim[0].stride = 1; ! ret->data = internal_malloc_size (0); ! ret->offset = 0; ! ! return; ! } } /* Setup the array descriptor. */ ret->dim[0].lbound = 0; ret->dim[0].ubound = total - 1; ret->dim[0].stride = 1; - - ret->data = internal_malloc_size (size * total); ret->offset = 0; } rstride0 = ret->dim[0].stride * size; --- 358,380 ---- total *= extent[n]; } else ! /* The result array will be empty. */ ! total = 0; } /* Setup the array descriptor. */ ret->dim[0].lbound = 0; ret->dim[0].ubound = total - 1; ret->dim[0].stride = 1; ret->offset = 0; + + if (total == 0) + { + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (size * total); } rstride0 = ret->dim[0].stride * size; *************** pack_s_internal (gfc_array_char *ret, co *** 384,390 **** If MASK is .FALSE., we have to copy VECTOR into the result array. If VECTOR were not present we would have already returned. */ ! if (*mask) { while (sptr) { --- 388,394 ---- If MASK is .FALSE., we have to copy VECTOR into the result array. If VECTOR were not present we would have already returned. */ ! if (*mask && ssize != 0) { while (sptr) { diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/rand.c gcc-4.1.2/libgfortran/intrinsics/rand.c *** gcc-4.1.1/libgfortran/intrinsics/rand.c Tue Nov 22 10:58:47 2005 --- gcc-4.1.2/libgfortran/intrinsics/rand.c Sat Aug 26 19:17:35 2006 *************** export_proto_np(PREFIX(rand)); *** 122,128 **** GFC_REAL_4 PREFIX(rand) (GFC_INTEGER_4 *i) { ! return normalize_r4_i4 (irand (i) - 1, GFC_RAND_M1 - 1); } #ifndef __GTHREAD_MUTEX_INIT --- 122,136 ---- GFC_REAL_4 PREFIX(rand) (GFC_INTEGER_4 *i) { ! GFC_UINTEGER_4 mask; ! #if GFC_REAL_4_RADIX == 2 ! mask = ~ (GFC_UINTEGER_4) 0u << (32 - GFC_REAL_4_DIGITS + 1); ! #elif GFC_REAL_4_RADIX == 16 ! mask = ~ (GFC_UINTEGER_4) 0u << ((8 - GFC_REAL_4_DIGITS) * 4 + 1); ! #else ! #error "GFC_REAL_4_RADIX has unknown value" ! #endif ! return ((GFC_UINTEGER_4) (irand(i) -1) & mask) * (GFC_REAL_4) 0x1.p-31f; } #ifndef __GTHREAD_MUTEX_INIT diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/random.c gcc-4.1.2/libgfortran/intrinsics/random.c *** gcc-4.1.1/libgfortran/intrinsics/random.c Sun Dec 4 18:22:20 2005 --- gcc-4.1.2/libgfortran/intrinsics/random.c Sat Aug 26 19:17:35 2006 *************** export_proto(arandom_r4); *** 45,57 **** --- 45,152 ---- extern void arandom_r8 (gfc_array_r8 *); export_proto(arandom_r8); + #ifdef HAVE_GFC_REAL_10 + + extern void random_r10 (GFC_REAL_10 *); + iexport_proto(random_r10); + + extern void arandom_r10 (gfc_array_r10 *); + export_proto(arandom_r10); + + #endif + + #ifdef HAVE_GFC_REAL_16 + + extern void random_r16 (GFC_REAL_16 *); + iexport_proto(random_r16); + + extern void arandom_r16 (gfc_array_r16 *); + export_proto(arandom_r16); + + #endif + #ifdef __GTHREAD_MUTEX_INIT static __gthread_mutex_t random_lock = __GTHREAD_MUTEX_INIT; #else static __gthread_mutex_t random_lock; #endif + /* Helper routines to map a GFC_UINTEGER_* to the corresponding + GFC_REAL_* types in the range of [0,1). If GFC_REAL_*_RADIX are 2 + or 16, respectively, we mask off the bits that don't fit into the + correct GFC_REAL_*, convert to the real type, then multiply by the + correct offset. + */ + + + static inline void + rnumber_4 (GFC_REAL_4 *f, GFC_UINTEGER_4 v) + { + GFC_UINTEGER_4 mask; + #if GFC_REAL_4_RADIX == 2 + mask = ~ (GFC_UINTEGER_4) 0u << (32 - GFC_REAL_4_DIGITS); + #elif GFC_REAL_4_RADIX == 16 + mask = ~ (GFC_UINTEGER_4) 0u << ((8 - GFC_REAL_4_DIGITS) * 4); + #else + #error "GFC_REAL_4_RADIX has unknown value" + #endif + v = v & mask; + *f = (GFC_REAL_4) v * (GFC_REAL_4) 0x1.p-32f; + } + + static inline void + rnumber_8 (GFC_REAL_8 *f, GFC_UINTEGER_8 v) + { + GFC_UINTEGER_8 mask; + #if GFC_REAL_8_RADIX == 2 + mask = ~ (GFC_UINTEGER_8) 0u << (64 - GFC_REAL_8_DIGITS); + #elif GFC_REAL_8_RADIX == 16 + mask = ~ (GFC_UINTEGER_8) 0u << (16 - GFC_REAL_8_DIGITS) * 4); + #else + #error "GFC_REAL_8_RADIX has unknown value" + #endif + v = v & mask; + *f = (GFC_REAL_8) v * (GFC_REAL_8) 0x1.p-64; + } + + #ifdef HAVE_GFC_REAL_10 + static inline void + rnumber_10 (GFC_REAL_10 *f, GFC_UINTEGER_8 v) + { + GFC_UINTEGER_8 mask; + #if GFC_REAL_10_RADIX == 2 + mask = ~ (GFC_UINTEGER_8) 0u << (64 - GFC_REAL_10_DIGITS); + #elif GFC_REAL_10_RADIX == 16 + mask = ~ (GFC_UINTEGER_10) 0u << ((16 - GFC_REAL_10_DIGITS) * 4); + #else + #error "GFC_REAL_10_RADIX has unknown value" + #endif + v = v & mask; + *f = (GFC_REAL_10) v * (GFC_REAL_10) 0x1.p-64; + } + #endif + + #ifdef HAVE_GFC_REAL_16 + + /* For REAL(KIND=16), we only need to mask off the lower bits. */ + + static inline void + rnumber_16 (GFC_REAL_16 *f, GFC_UINTEGER_8 v1, GFC_UINTEGER_8 v2) + { + GFC_UINTEGER_8 mask; + #if GFC_REAL_16_RADIX == 2 + mask = ~ (GFC_UINTEGER_8) 0u << (128 - GFC_REAL_16_DIGITS); + #elif GFC_REAL_16_RADIX == 16 + mask = ~ (GFC_UINTEGER_8) 0u << ((32 - GFC_REAL_16_DIGITS) * 4); + #else + #error "GFC_REAL_16_RADIX has unknown value" + #endif + v2 = v2 & mask; + *f = (GFC_REAL_16) v1 * (GFC_REAL_16) 0x1.p-64 + + (GFC_REAL_16) v2 * (GFC_REAL_16) 0x1.p-128; + } + #endif /* libgfortran previously had a Mersenne Twister, taken from the paper: Mersenne Twister: 623-dimensionally equidistributed *************** static __gthread_mutex_t random_lock; *** 111,138 **** "There is no copyright on the code below." included the original KISS algorithm. */ #define GFC_SL(k, n) ((k)^((k)<<(n))) #define GFC_SR(k, n) ((k)^((k)>>(n))) ! static const GFC_INTEGER_4 kiss_size = 4; ! #define KISS_DEFAULT_SEED {123456789, 362436069, 521288629, 916191069} ! static const GFC_UINTEGER_4 kiss_default_seed[4] = KISS_DEFAULT_SEED; ! static GFC_UINTEGER_4 kiss_seed[4] = KISS_DEFAULT_SEED; /* kiss_random_kernel() returns an integer value in the range of (0, GFC_UINTEGER_4_HUGE]. The distribution of pseudorandom numbers should be uniform. */ static GFC_UINTEGER_4 ! kiss_random_kernel(void) { GFC_UINTEGER_4 kiss; ! kiss_seed[0] = 69069 * kiss_seed[0] + 1327217885; ! kiss_seed[1] = GFC_SL(GFC_SR(GFC_SL(kiss_seed[1],13),17),5); ! kiss_seed[2] = 18000 * (kiss_seed[2] & 65535) + (kiss_seed[2] >> 16); ! kiss_seed[3] = 30903 * (kiss_seed[3] & 65535) + (kiss_seed[3] >> 16); ! kiss = kiss_seed[0] + kiss_seed[1] + (kiss_seed[2] << 16) + kiss_seed[3]; return kiss; } --- 206,282 ---- "There is no copyright on the code below." included the original KISS algorithm. */ + /* We use three KISS random number generators, with different + seeds. + As a matter of Quality of Implementation, the random numbers + we generate for different REAL kinds, starting from the same + seed, are always the same up to the precision of these types. + We do this by using three generators with different seeds, the + first one always for the most significant bits, the second one + for bits 33..64 (if present in the REAL kind), and the third one + (called twice) for REAL(16). + */ + #define GFC_SL(k, n) ((k)^((k)<<(n))) #define GFC_SR(k, n) ((k)^((k)>>(n))) ! /* Reference for the seed: ! From: "George Marsaglia" ! Newsgroups: sci.math ! Message-ID: ! ! The KISS RNG uses four seeds, x, y, z, c, ! with 0<=x<2^32, 0> 16); ! seed[3] = 30903 * (seed[3] & 65535) + (seed[3] >> 16); ! kiss = seed[0] + seed[1] + (seed[2] << 16) + seed[3]; return kiss; } *************** random_r4 (GFC_REAL_4 *x) *** 146,156 **** GFC_UINTEGER_4 kiss; __gthread_mutex_lock (&random_lock); ! kiss = kiss_random_kernel (); ! /* Burn a random number, so the REAL*4 and REAL*8 functions ! produce similar sequences of random numbers. */ ! kiss_random_kernel (); ! *x = normalize_r4_i4 (kiss, ~(GFC_UINTEGER_4) 0); __gthread_mutex_unlock (&random_lock); } iexport(random_r4); --- 290,297 ---- GFC_UINTEGER_4 kiss; __gthread_mutex_lock (&random_lock); ! kiss = kiss_random_kernel (kiss_seed_1); ! rnumber_4 (x, kiss); __gthread_mutex_unlock (&random_lock); } iexport(random_r4); *************** random_r8 (GFC_REAL_8 *x) *** 164,176 **** GFC_UINTEGER_8 kiss; __gthread_mutex_lock (&random_lock); ! kiss = ((GFC_UINTEGER_8)kiss_random_kernel ()) << 32; ! kiss += kiss_random_kernel (); ! *x = normalize_r8_i8 (kiss, ~(GFC_UINTEGER_8) 0); __gthread_mutex_unlock (&random_lock); } iexport(random_r8); /* This function fills a REAL(4) array with values from the uniform distribution with range [0,1). */ --- 305,361 ---- GFC_UINTEGER_8 kiss; __gthread_mutex_lock (&random_lock); ! kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; ! kiss += kiss_random_kernel (kiss_seed_2); ! rnumber_8 (x, kiss); __gthread_mutex_unlock (&random_lock); } iexport(random_r8); + #ifdef HAVE_GFC_REAL_10 + + /* This function produces a REAL(10) value from the uniform distribution + with range [0,1). */ + + void + random_r10 (GFC_REAL_10 *x) + { + GFC_UINTEGER_8 kiss; + + __gthread_mutex_lock (&random_lock); + kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; + kiss += kiss_random_kernel (kiss_seed_2); + rnumber_10 (x, kiss); + __gthread_mutex_unlock (&random_lock); + } + iexport(random_r10); + + #endif + + /* This function produces a REAL(16) value from the uniform distribution + with range [0,1). */ + + #ifdef HAVE_GFC_REAL_16 + + void + random_r16 (GFC_REAL_16 *x) + { + GFC_UINTEGER_8 kiss1, kiss2; + + __gthread_mutex_lock (&random_lock); + kiss1 = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; + kiss1 += kiss_random_kernel (kiss_seed_2); + + kiss2 = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_3)) << 32; + kiss2 += kiss_random_kernel (kiss_seed_3); + + rnumber_16 (x, kiss1, kiss2); + __gthread_mutex_unlock (&random_lock); + } + iexport(random_r16); + + + #endif /* This function fills a REAL(4) array with values from the uniform distribution with range [0,1). */ *************** arandom_r4 (gfc_array_r4 *x) *** 209,219 **** while (dest) { /* random_r4 (dest); */ ! kiss = kiss_random_kernel (); ! /* Burn a random number, so the REAL*4 and REAL*8 functions ! produce similar sequences of random numbers. */ ! kiss_random_kernel (); ! *dest = normalize_r4_i4 (kiss, ~(GFC_UINTEGER_4) 0); /* Advance to the next element. */ dest += stride0; --- 394,401 ---- while (dest) { /* random_r4 (dest); */ ! kiss = kiss_random_kernel (kiss_seed_1); ! rnumber_4 (dest, kiss); /* Advance to the next element. */ dest += stride0; *************** arandom_r8 (gfc_array_r8 *x) *** 282,290 **** while (dest) { /* random_r8 (dest); */ ! kiss = ((GFC_UINTEGER_8)kiss_random_kernel ()) << 32; ! kiss += kiss_random_kernel (); ! *dest = normalize_r8_i8 (kiss, ~(GFC_UINTEGER_8) 0); /* Advance to the next element. */ dest += stride0; --- 464,618 ---- while (dest) { /* random_r8 (dest); */ ! kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; ! kiss += kiss_random_kernel (kiss_seed_2); ! rnumber_8 (dest, kiss); ! ! /* Advance to the next element. */ ! dest += stride0; ! count[0]++; ! /* Advance to the next source element. */ ! n = 0; ! while (count[n] == extent[n]) ! { ! /* When we get to the end of a dimension, reset it and increment ! the next dimension. */ ! count[n] = 0; ! /* We could precalculate these products, but this is a less ! frequently used path so probably not worth it. */ ! dest -= stride[n] * extent[n]; ! n++; ! if (n == dim) ! { ! dest = NULL; ! break; ! } ! else ! { ! count[n]++; ! dest += stride[n]; ! } ! } ! } ! __gthread_mutex_unlock (&random_lock); ! } ! ! #ifdef HAVE_GFC_REAL_10 ! ! /* This function fills a REAL(10) array with values from the uniform ! distribution with range [0,1). */ ! ! void ! arandom_r10 (gfc_array_r10 *x) ! { ! index_type count[GFC_MAX_DIMENSIONS]; ! index_type extent[GFC_MAX_DIMENSIONS]; ! index_type stride[GFC_MAX_DIMENSIONS]; ! index_type stride0; ! index_type dim; ! GFC_REAL_10 *dest; ! GFC_UINTEGER_8 kiss; ! int n; ! ! dest = x->data; ! ! dim = GFC_DESCRIPTOR_RANK (x); ! ! for (n = 0; n < dim; n++) ! { ! count[n] = 0; ! stride[n] = x->dim[n].stride; ! extent[n] = x->dim[n].ubound + 1 - x->dim[n].lbound; ! if (extent[n] <= 0) ! return; ! } ! ! stride0 = stride[0]; ! ! __gthread_mutex_lock (&random_lock); ! ! while (dest) ! { ! /* random_r10 (dest); */ ! kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; ! kiss += kiss_random_kernel (kiss_seed_2); ! rnumber_10 (dest, kiss); ! ! /* Advance to the next element. */ ! dest += stride0; ! count[0]++; ! /* Advance to the next source element. */ ! n = 0; ! while (count[n] == extent[n]) ! { ! /* When we get to the end of a dimension, reset it and increment ! the next dimension. */ ! count[n] = 0; ! /* We could precalculate these products, but this is a less ! frequently used path so probably not worth it. */ ! dest -= stride[n] * extent[n]; ! n++; ! if (n == dim) ! { ! dest = NULL; ! break; ! } ! else ! { ! count[n]++; ! dest += stride[n]; ! } ! } ! } ! __gthread_mutex_unlock (&random_lock); ! } ! ! #endif ! ! #ifdef HAVE_GFC_REAL_16 ! ! /* This function fills a REAL(16) array with values from the uniform ! distribution with range [0,1). */ ! ! void ! arandom_r16 (gfc_array_r16 *x) ! { ! index_type count[GFC_MAX_DIMENSIONS]; ! index_type extent[GFC_MAX_DIMENSIONS]; ! index_type stride[GFC_MAX_DIMENSIONS]; ! index_type stride0; ! index_type dim; ! GFC_REAL_16 *dest; ! GFC_UINTEGER_8 kiss1, kiss2; ! int n; ! ! dest = x->data; ! ! dim = GFC_DESCRIPTOR_RANK (x); ! ! for (n = 0; n < dim; n++) ! { ! count[n] = 0; ! stride[n] = x->dim[n].stride; ! extent[n] = x->dim[n].ubound + 1 - x->dim[n].lbound; ! if (extent[n] <= 0) ! return; ! } ! ! stride0 = stride[0]; ! ! __gthread_mutex_lock (&random_lock); ! ! while (dest) ! { ! /* random_r16 (dest); */ ! kiss1 = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; ! kiss1 += kiss_random_kernel (kiss_seed_2); ! ! kiss2 = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_3)) << 32; ! kiss2 += kiss_random_kernel (kiss_seed_3); ! ! rnumber_16 (dest, kiss1, kiss2); /* Advance to the next element. */ dest += stride0; *************** arandom_r8 (gfc_array_r8 *x) *** 315,320 **** --- 643,650 ---- __gthread_mutex_unlock (&random_lock); } + #endif + /* random_seed is used to seed the PRNG with either a default set of seeds or user specified set of seeds. random_seed must be called with no argument or exactly one argument. */ *************** random_seed (GFC_INTEGER_4 *size, gfc_ar *** 330,339 **** { /* From the standard: "If no argument is present, the processor assigns a processor-dependent value to the seed." */ ! kiss_seed[0] = kiss_default_seed[0]; ! kiss_seed[1] = kiss_default_seed[1]; ! kiss_seed[2] = kiss_default_seed[2]; ! kiss_seed[3] = kiss_default_seed[3]; } if (size != NULL) --- 660,669 ---- { /* From the standard: "If no argument is present, the processor assigns a processor-dependent value to the seed." */ ! ! for (i=0; idata[i * put->dim[0].stride]; } /* Return the seed to GET data. */ --- 684,690 ---- /* This code now should do correct strides. */ for (i = 0; i < kiss_size; i++) ! kiss_seed[i] =(GFC_UINTEGER_4) put->data[i * put->dim[0].stride]; } /* Return the seed to GET data. */ diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/reshape_generic.c gcc-4.1.2/libgfortran/intrinsics/reshape_generic.c *** gcc-4.1.1/libgfortran/intrinsics/reshape_generic.c Tue Sep 13 07:15:01 2005 --- gcc-4.1.2/libgfortran/intrinsics/reshape_generic.c Tue Nov 14 06:19:04 2006 *************** Boston, MA 02110-1301, USA. */ *** 37,45 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) parray; - /* The shape parameter is ignored. We can currently deduce the shape from the - return array. */ - static void reshape_internal (parray *ret, parray *source, shape_type *shape, parray *pad, shape_type *order, index_type size) --- 37,42 ---- *************** reshape_internal (parray *ret, parray *s *** 73,78 **** --- 70,76 ---- const char *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_internal (parray *ret, parray *s *** 87,93 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 85,91 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_internal (parray *ret, parray *s *** 131,143 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 129,145 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_internal (parray *ret, parray *s *** 149,161 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 151,168 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_internal (parray *ret, parray *s *** 167,172 **** --- 174,180 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_internal (parray *ret, parray *s *** 184,189 **** --- 192,215 ---- rstride0 = rstride[0] * size; sstride0 = sstride[0] * size; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * size; + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_internal (parray *ret, parray *s *** 193,198 **** --- 219,225 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) *************** reshape_internal (parray *ret, parray *s *** 215,221 **** rcount[n]++; rptr += rstride[n] * size; } ! } /* Advance to the next source element. */ n = 0; while (scount[n] == sextent[n]) --- 242,249 ---- rcount[n]++; rptr += rstride[n] * size; } ! } ! /* Advance to the next source element. */ n = 0; while (scount[n] == sextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/spread_generic.c gcc-4.1.2/libgfortran/intrinsics/spread_generic.c *** gcc-4.1.1/libgfortran/intrinsics/spread_generic.c Sun Oct 23 06:59:17 2005 --- gcc-4.1.2/libgfortran/intrinsics/spread_generic.c Tue Nov 14 06:19:04 2006 *************** spread_internal (gfc_array_char *ret, co *** 101,107 **** } } ret->offset = 0; ! ret->data = internal_malloc_size (rs * size); } else { --- 101,113 ---- } } ret->offset = 0; ! if (rs > 0) ! ret->data = internal_malloc_size (rs * size); ! else ! { ! ret->data = internal_malloc_size (1); ! return; ! } } else { diff -Nrcpad gcc-4.1.1/libgfortran/intrinsics/string_intrinsics.c gcc-4.1.2/libgfortran/intrinsics/string_intrinsics.c *** gcc-4.1.1/libgfortran/intrinsics/string_intrinsics.c Sat Nov 12 19:16:40 2005 --- gcc-4.1.2/libgfortran/intrinsics/string_intrinsics.c Tue Jun 20 06:04:14 2006 *************** compare_string (GFC_INTEGER_4 len1, cons *** 109,115 **** const char *s; int len; ! res = strncmp (s1, s2, (len1 < len2) ? len1 : len2); if (res != 0) return res; --- 109,115 ---- const char *s; int len; ! res = memcmp (s1, s2, (len1 < len2) ? len1 : len2); if (res != 0) return res; diff -Nrcpad gcc-4.1.1/libgfortran/io/close.c gcc-4.1.2/libgfortran/io/close.c *** gcc-4.1.1/libgfortran/io/close.c Tue Nov 22 10:58:47 2005 --- gcc-4.1.2/libgfortran/io/close.c Mon Jul 31 01:57:25 2006 *************** st_close (st_parameter_close *clp) *** 103,107 **** --- 103,108 ---- #endif } + /* CLOSE on unconnected unit is legal and a no-op: F95 std., 9.3.5. */ library_end (); } diff -Nrcpad gcc-4.1.1/libgfortran/io/file_pos.c gcc-4.1.2/libgfortran/io/file_pos.c *** gcc-4.1.1/libgfortran/io/file_pos.c Fri Mar 31 21:13:46 2006 --- gcc-4.1.2/libgfortran/io/file_pos.c Mon Jul 31 01:57:25 2006 *************** st_flush (st_parameter_filepos *fpp) *** 340,345 **** --- 340,349 ---- flush (u->s); unlock_unit (u); } + else + /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ + generate_error (&fpp->common, ERROR_BAD_OPTION, + "Specified UNIT in FLUSH is not connected"); library_end (); } diff -Nrcpad gcc-4.1.1/libgfortran/io/io.h gcc-4.1.2/libgfortran/io/io.h *** gcc-4.1.1/libgfortran/io/io.h Sat Apr 29 04:27:09 2006 --- gcc-4.1.2/libgfortran/io/io.h Sat Nov 25 07:22:49 2006 *************** typedef struct st_parameter_dt *** 417,423 **** /* An internal unit specific flag used to identify that the associated unit is internal. */ unsigned unit_is_internal : 1; ! /* 17 unused bits. */ char last_char; char nml_delim; --- 417,426 ---- /* An internal unit specific flag used to identify that the associated unit is internal. */ unsigned unit_is_internal : 1; ! /* An internal unit specific flag to signify an EOF condition for list ! directed read. */ ! unsigned at_eof : 1; ! /* 16 unused bits. */ char last_char; char nml_delim; *************** typedef struct st_parameter_dt *** 432,438 **** struct format_data *fmt; jmp_buf *eof_jump; namelist_info *ionml; ! /* Storage area for values except for strings. Must be large enough to hold a complex value (two reals) of the largest kind. */ --- 435,443 ---- struct format_data *fmt; jmp_buf *eof_jump; namelist_info *ionml; ! /* A flag used to identify when a non-standard expanded namelist read ! has occurred. */ ! int expanded_read; /* Storage area for values except for strings. Must be large enough to hold a complex value (two reals) of the largest kind. */ *************** typedef struct *** 467,472 **** --- 472,478 ---- unit_status status; unit_pad pad; unit_convert convert; + int has_recl; } unit_flags; diff -Nrcpad gcc-4.1.1/libgfortran/io/list_read.c gcc-4.1.2/libgfortran/io/list_read.c *** gcc-4.1.1/libgfortran/io/list_read.c Sun Apr 30 19:53:41 2006 --- gcc-4.1.2/libgfortran/io/list_read.c Sat Jan 13 21:00:31 2007 *************** next_char (st_parameter_dt *dtp) *** 163,185 **** dtp->u.p.line_buffer_enabled = 0; } ! /* Handle the end-of-record condition for internal array unit */ ! if (is_array_io(dtp) && dtp->u.p.current_unit->bytes_left == 0) { ! c = '\n'; ! record = next_array_record (dtp, dtp->u.p.current_unit->ls); ! /* Check for "end-of-file condition */ ! if (record == 0) ! longjmp (*dtp->u.p.eof_jump, 1); ! record *= dtp->u.p.current_unit->recl; ! ! if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) ! longjmp (*dtp->u.p.eof_jump, 1); ! dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; ! goto done; } /* Get the next character and handle end-of-record conditions */ --- 163,195 ---- dtp->u.p.line_buffer_enabled = 0; } ! /* Handle the end-of-record and end-of-file conditions for ! internal array unit. */ ! if (is_array_io(dtp)) { ! if (dtp->u.p.at_eof) ! longjmp (*dtp->u.p.eof_jump, 1); ! /* Check for "end-of-record" condition. */ ! if (dtp->u.p.current_unit->bytes_left == 0) ! { ! c = '\n'; ! record = next_array_record (dtp, dtp->u.p.current_unit->ls); ! /* Check for "end-of-file" condition. */ ! if (record == 0) ! { ! dtp->u.p.at_eof = 1; ! goto done; ! } ! record *= dtp->u.p.current_unit->recl; ! if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) ! longjmp (*dtp->u.p.eof_jump, 1); ! ! dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; ! goto done; ! } } /* Get the next character and handle end-of-record conditions */ *************** next_char (st_parameter_dt *dtp) *** 193,199 **** if (is_array_io(dtp)) { /* End of record is handled in the next pass through, above. The ! check for NULL here is cautionary. */ if (p == NULL) { generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); --- 203,209 ---- if (is_array_io(dtp)) { /* End of record is handled in the next pass through, above. The ! check for NULL here is cautionary. */ if (p == NULL) { generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL); *************** finish_separator (st_parameter_dt *dtp) *** 352,358 **** case '/': dtp->u.p.input_complete = 1; ! if (!dtp->u.p.namelist_mode) next_record (dtp, 0); break; case '\n': --- 362,369 ---- case '/': dtp->u.p.input_complete = 1; ! if (!dtp->u.p.namelist_mode) ! return; break; case '\n': *************** list_formatted_read_scalar (st_parameter *** 1482,1496 **** c = eat_spaces (dtp); if (is_separator (c)) ! { /* Found a null value. */ eat_separator (dtp); dtp->u.p.repeat_count = 0; ! /* eat_separator sets this flag if the separator was a comma */ if (dtp->u.p.comma_flag) goto cleanup; ! /* eat_separator sets this flag if the separator was a \n or \r */ if (dtp->u.p.at_eol) finish_separator (dtp); else --- 1493,1508 ---- c = eat_spaces (dtp); if (is_separator (c)) ! { ! /* Found a null value. */ eat_separator (dtp); dtp->u.p.repeat_count = 0; ! /* eat_separator sets this flag if the separator was a comma. */ if (dtp->u.p.comma_flag) goto cleanup; ! /* eat_separator sets this flag if the separator was a \n or \r. */ if (dtp->u.p.at_eol) finish_separator (dtp); else *************** list_formatted_read_scalar (st_parameter *** 1515,1521 **** else { eat_spaces (dtp); ! /* trailing spaces prior to end of line */ if (dtp->u.p.at_eol) finish_separator (dtp); } --- 1527,1533 ---- else { eat_spaces (dtp); ! /* Trailing spaces prior to end of line. */ if (dtp->u.p.at_eol) finish_separator (dtp); } *************** nml_parse_qualifier (st_parameter_dt *dt *** 1660,1667 **** --- 1672,1683 ---- int indx; int neg; int null_flag; + int is_array_section; char c; + is_array_section = 0; + dtp->u.p.expanded_read = 0; + /* The next character in the stream should be the '('. */ c = next_char (dtp); *************** nml_parse_qualifier (st_parameter_dt *dt *** 1700,1705 **** --- 1716,1722 ---- switch (c) { case ':': + is_array_section = 1; break; case ',': case ')': *************** nml_parse_qualifier (st_parameter_dt *dt *** 1775,1781 **** if (indx == 0) { memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t)); ! ls[dim].end = ls[dim].start; } break; } --- 1792,1805 ---- if (indx == 0) { memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t)); ! ! /* If -std=f95/2003 or an array section is specified, ! do not allow excess data to be processed. */ ! if (is_array_section == 1 ! || compile_options.allow_std < GFC_STD_GNU) ! ls[dim].end = ls[dim].start; ! else ! dtp->u.p.expanded_read = 1; } break; } *************** nml_read_obj (st_parameter_dt *dtp, name *** 2019,2025 **** index_type dlen; index_type m; index_type obj_name_len; ! void * pdata ; /* This object not touched in name parsing. */ --- 2043,2049 ---- index_type dlen; index_type m; index_type obj_name_len; ! void * pdata; /* This object not touched in name parsing. */ *************** nml_read_obj (st_parameter_dt *dtp, name *** 2112,2117 **** --- 2136,2145 ---- strcpy (obj_name, nl->var_name); strcat (obj_name, "%"); + /* If reading a derived type, disable the expanded read warning + since a single object can have multiple reads. */ + dtp->u.p.expanded_read = 0; + /* Now loop over the components. Update the component pointer with the return value from nml_write_obj. This loop jumps past nested derived types by testing if the potential *************** nml_read_obj (st_parameter_dt *dtp, name *** 2157,2167 **** *pprev_nl = nl; if (dtp->u.p.nml_read_error) ! return SUCCESS; if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN) ! goto incr_idx; ! /* Note the switch from GFC_DTYPE_type to BT_type at this point. This comes about because the read functions return BT_types. */ --- 2185,2200 ---- *pprev_nl = nl; if (dtp->u.p.nml_read_error) ! { ! dtp->u.p.expanded_read = 0; ! return SUCCESS; ! } if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN) ! { ! dtp->u.p.expanded_read = 0; ! goto incr_idx; ! } /* Note the switch from GFC_DTYPE_type to BT_type at this point. This comes about because the read functions return BT_types. */ *************** nml_read_obj (st_parameter_dt *dtp, name *** 2182,2195 **** memcpy (pdata, dtp->u.p.saved_string, m); if (m < dlen) memset ((void*)( pdata + m ), ' ', dlen - m); ! break; default: break; } ! /* Break out of loop if scalar. */ if (!nl->var_rank) break; --- 2215,2241 ---- memcpy (pdata, dtp->u.p.saved_string, m); if (m < dlen) memset ((void*)( pdata + m ), ' ', dlen - m); ! break; default: break; } ! /* Warn if a non-standard expanded read occurs. A single read of a ! single object is acceptable. If a second read occurs, issue a warning ! and set the flag to zero to prevent further warnings. */ ! if (dtp->u.p.expanded_read == 2) ! { ! notify_std (GFC_STD_GNU, "Non-standard expanded namelist read."); ! dtp->u.p.expanded_read = 0; ! } ! ! /* If the expanded read warning flag is set, increment it, ! indicating that a single read has occured. */ ! if (dtp->u.p.expanded_read >= 1) ! dtp->u.p.expanded_read++; + /* Break out of loop if scalar. */ if (!nl->var_rank) break; *************** namelist_read (st_parameter_dt *dtp) *** 2500,2505 **** --- 2546,2552 ---- dtp->u.p.namelist_mode = 1; dtp->u.p.input_complete = 0; + dtp->u.p.expanded_read = 0; dtp->u.p.eof_jump = &eof_jump; if (setjmp (eof_jump)) diff -Nrcpad gcc-4.1.1/libgfortran/io/open.c gcc-4.1.2/libgfortran/io/open.c *** gcc-4.1.1/libgfortran/io/open.c Fri Mar 31 21:13:46 2006 --- gcc-4.1.2/libgfortran/io/open.c Sat Nov 25 07:22:49 2006 *************** new_unit (st_parameter_open *opp, gfc_un *** 397,405 **** /* Unspecified recl ends up with a processor dependent value. */ if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)) ! u->recl = opp->recl_in; else { switch (compile_options.record_marker) { case 0: --- 397,409 ---- /* Unspecified recl ends up with a processor dependent value. */ if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)) ! { ! u->flags.has_recl = 1; ! u->recl = opp->recl_in; ! } else { + u->flags.has_recl = 0; switch (compile_options.record_marker) { case 0: diff -Nrcpad gcc-4.1.1/libgfortran/io/transfer.c gcc-4.1.2/libgfortran/io/transfer.c *** gcc-4.1.1/libgfortran/io/transfer.c Sun Apr 30 20:59:08 2006 --- gcc-4.1.2/libgfortran/io/transfer.c Mon Dec 25 22:56:54 2006 *************** read_block (st_parameter_dt *dtp, int *l *** 307,367 **** static void read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) { - int *length; - void *data; size_t nread; ! if (dtp->u.p.current_unit->bytes_left < *nbytes) { ! /* For preconnected units with default record length, set bytes left ! to unit record length and proceed, otherwise error. */ ! if (dtp->u.p.current_unit->unit_number == options.stdin_unit ! && dtp->u.p.current_unit->recl == DEFAULT_RECL) ! dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; ! else { ! if (dtp->u.p.current_unit->flags.pad == PAD_NO) ! { ! /* Not enough data left. */ ! generate_error (&dtp->common, ERROR_EOR, NULL); ! return; ! } } - - *nbytes = dtp->u.p.current_unit->bytes_left; } ! if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && ! dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) { ! length = (int *) nbytes; ! data = read_sf (dtp, length, 0); /* Special case. */ ! memcpy (buf, data, (size_t) *length); ! return; } ! dtp->u.p.current_unit->bytes_left -= *nbytes; - nread = *nbytes; if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0) { generate_error (&dtp->common, ERROR_OS, NULL); return; } ! if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ! dtp->u.p.size_used += (gfc_offset) nread; ! if (nread != *nbytes) ! { /* Short read, e.g. if we hit EOF. */ ! if (dtp->u.p.current_unit->flags.pad == PAD_YES) ! { ! memset (((char *) buf) + nread, ' ', *nbytes - nread); ! *nbytes = nread; ! } ! else ! generate_error (&dtp->common, ERROR_EOR, NULL); } } --- 307,356 ---- static void read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) { size_t nread; + int short_record; ! if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) { ! short_record = 1; ! nread = (size_t) dtp->u.p.current_unit->bytes_left; ! *nbytes = nread; ! ! if (dtp->u.p.current_unit->bytes_left == 0) { ! dtp->u.p.current_unit->endfile = AT_ENDFILE; ! generate_error (&dtp->common, ERROR_END, NULL); ! return; } } ! else { ! short_record = 0; ! nread = *nbytes; } ! dtp->u.p.current_unit->bytes_left -= nread; if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0) { generate_error (&dtp->common, ERROR_OS, NULL); return; } ! if (nread != *nbytes) /* Short read, e.g. if we hit EOF. */ ! { ! *nbytes = nread; ! generate_error (&dtp->common, ERROR_END, NULL); ! return; ! } ! if (short_record) ! { ! generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL); ! return; } + } *************** write_block (st_parameter_dt *dtp, int l *** 399,404 **** --- 388,396 ---- return NULL; } + if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE) + generate_error (&dtp->common, ERROR_END, NULL); + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) dtp->u.p.size_used += (gfc_offset) length; *************** unformatted_read (st_parameter_dt *dtp, *** 475,481 **** /* By now, all complex variables have been split into their constituent reals. For types with padding, we only need to read kind bytes. We don't care about the contents ! of the padding. */ sz = kind; for (i=0; iu.p.current_unit->s, &dummy, &nbytes) != 0) generate_error (&dtp->common, ERROR_OS, NULL); ! /* For sequential unformatted, we write until we have more bytes ! than can fit in the record markers. If disk space runs out first, ! it will error on the write. */ ! dtp->u.p.current_unit->recl = max_offset; dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } --- 1362,1372 ---- if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0) generate_error (&dtp->common, ERROR_OS, NULL); ! /* For sequential unformatted, if RECL= was not specified in the OPEN ! we write until we have more bytes than can fit in the record markers. ! If disk space runs out first, it will error on the write. */ ! if (dtp->u.p.current_unit->flags.has_recl == 0) ! dtp->u.p.current_unit->recl = max_offset; dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } *************** next_record_w (st_parameter_dt *dtp, int *** 2037,2045 **** case FORMATTED_SEQUENTIAL: - if (dtp->u.p.current_unit->bytes_left == 0) - break; - if (is_internal_unit (dtp)) { if (is_array_io (dtp)) --- 2031,2036 ---- *************** next_record_w (st_parameter_dt *dtp, int *** 2068,2074 **** /* Now that the current record has been padded out, determine where the next record in the array is. */ record = next_array_record (dtp, dtp->u.p.current_unit->ls); ! /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; --- 2059,2067 ---- /* Now that the current record has been padded out, determine where the next record in the array is. */ record = next_array_record (dtp, dtp->u.p.current_unit->ls); ! if (record == 0) ! dtp->u.p.current_unit->endfile = AT_ENDFILE; ! /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; *************** next_record_w (st_parameter_dt *dtp, int *** 2109,2114 **** --- 2102,2110 ---- } else { + if (dtp->u.p.current_unit->bytes_left == 0) + break; + /* If this is the last call to next_record move to the farthest position reached in preparation for completing the record. (for file unit) */ diff -Nrcpad gcc-4.1.1/libgfortran/io/unit.c gcc-4.1.2/libgfortran/io/unit.c *** gcc-4.1.1/libgfortran/io/unit.c Sat Apr 29 04:27:09 2006 --- gcc-4.1.2/libgfortran/io/unit.c Fri Oct 27 21:40:54 2006 *************** get_internal_unit (st_parameter_dt *dtp) *** 411,416 **** --- 411,417 ---- iunit->flags.form = FORM_FORMATTED; iunit->flags.pad = PAD_YES; iunit->flags.status = STATUS_UNSPECIFIED; + iunit->endfile = NO_ENDFILE; /* Initialize the data transfer parameters. */ *************** get_internal_unit (st_parameter_dt *dtp) *** 420,425 **** --- 421,427 ---- dtp->u.p.skips = 0; dtp->u.p.pending_spaces = 0; dtp->u.p.max_pos = 0; + dtp->u.p.at_eof = 0; /* This flag tells us the unit is assigned to internal I/O. */ diff -Nrcpad gcc-4.1.1/libgfortran/io/unix.c gcc-4.1.2/libgfortran/io/unix.c *** gcc-4.1.1/libgfortran/io/unix.c Sat Apr 29 04:27:09 2006 --- gcc-4.1.2/libgfortran/io/unix.c Tue May 30 02:51:26 2006 *************** fd_seek (unix_stream * s, gfc_offset off *** 569,574 **** --- 569,575 ---- } s->physical_offset = s->logical_offset = offset; + s->active = 0; return (lseek (s->fd, offset, SEEK_SET) < 0) ? FAILURE : SUCCESS; } diff -Nrcpad gcc-4.1.1/libgfortran/libgfortran.h gcc-4.1.2/libgfortran/libgfortran.h *** gcc-4.1.1/libgfortran/libgfortran.h Sun Apr 9 09:00:49 2006 --- gcc-4.1.2/libgfortran/libgfortran.h Sat Nov 4 14:04:27 2006 *************** Boston, MA 02110-1301, USA. */ *** 33,38 **** --- 33,39 ---- #include #include + #include #ifndef M_PI #define M_PI 3.14159265358979323846264338327 *************** internal_proto(l8_to_l4_offset); *** 228,233 **** --- 229,252 ---- #define GFC_REAL_16_HUGE LDBL_MAX #endif + #define GFC_REAL_4_DIGITS FLT_MANT_DIG + #define GFC_REAL_8_DIGITS DBL_MANT_DIG + #ifdef HAVE_GFC_REAL_10 + #define GFC_REAL_10_DIGITS LDBL_MANT_DIG + #endif + #ifdef HAVE_GFC_REAL_16 + #define GFC_REAL_16_DIGITS LDBL_MANT_DIG + #endif + + #define GFC_REAL_4_RADIX FLT_RADIX + #define GFC_REAL_8_RADIX FLT_RADIX + #ifdef HAVE_GFC_REAL_10 + #define GFC_REAL_10_RADIX FLT_RADIX + #endif + #ifdef HAVE_GFC_REAL_16 + #define GFC_REAL_16_RADIX FLT_RADIX + #endif + #ifndef GFC_MAX_DIMENSIONS #define GFC_MAX_DIMENSIONS 7 #endif *************** typedef enum *** 382,387 **** --- 401,407 ---- ERROR_INTERNAL_UNIT, ERROR_ALLOCATION, ERROR_DIRECT_EOR, + ERROR_SHORT_RECORD, ERROR_LAST /* Not a real error, the last error # + 1. */ } error_codes; *************** extern void random_seed (GFC_INTEGER_4 * *** 616,629 **** gfc_array_i4 * get); iexport_proto(random_seed); - /* normalize.c */ - - extern GFC_REAL_4 normalize_r4_i4 (GFC_UINTEGER_4, GFC_UINTEGER_4); - internal_proto(normalize_r4_i4); - - extern GFC_REAL_8 normalize_r8_i8 (GFC_UINTEGER_8, GFC_UINTEGER_8); - internal_proto(normalize_r8_i8); - /* size.c */ typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) array_t; --- 636,641 ---- diff -Nrcpad gcc-4.1.1/libgfortran/m4/matmul.m4 gcc-4.1.2/libgfortran/m4/matmul.m4 *** gcc-4.1.1/libgfortran/m4/matmul.m4 Sun May 7 13:02:39 2006 --- gcc-4.1.2/libgfortran/m4/matmul.m4 Sun Sep 10 17:26:54 2006 *************** sinclude(`matmul_asm_'rtype_code`.m4')dn *** 206,212 **** } } } ! else { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) --- 206,250 ---- } } } ! else if (rxstride == 1 && aystride == 1 && bxstride == 1) ! { ! if (GFC_DESCRIPTOR_RANK (a) != 1) ! { ! const rtype_name *restrict abase_x; ! const rtype_name *restrict bbase_y; ! rtype_name *restrict dest_y; ! rtype_name s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! dest_y = &dest[y*rystride]; ! for (x = 0; x < xcount; x++) ! { ! abase_x = &abase[x*axstride]; ! s = (rtype_name) 0; ! for (n = 0; n < count; n++) ! s += abase_x[n] * bbase_y[n]; ! dest_y[x] = s; ! } ! } ! } ! else ! { ! const rtype_name *restrict bbase_y; ! rtype_name s; ! ! for (y = 0; y < ycount; y++) ! { ! bbase_y = &bbase[y*bystride]; ! s = (rtype_name) 0; ! for (n = 0; n < count; n++) ! s += abase[n*axstride] * bbase_y[n]; ! dest[y*rystride] = s; ! } ! } ! } ! else if (axstride < aystride) { for (y = 0; y < ycount; y++) for (x = 0; x < xcount; x++) *************** sinclude(`matmul_asm_'rtype_code`.m4')dn *** 218,223 **** --- 256,296 ---- /* dest[x,y] += a[x,n] * b[n,y] */ dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const rtype_name *restrict bbase_y; + rtype_name s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (rtype_name) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const rtype_name *restrict abase_x; + const rtype_name *restrict bbase_y; + rtype_name *restrict dest_y; + rtype_name s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (rtype_name) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } } #endif diff -Nrcpad gcc-4.1.1/libgfortran/m4/reshape.m4 gcc-4.1.2/libgfortran/m4/reshape.m4 *** gcc-4.1.1/libgfortran/m4/reshape.m4 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/m4/reshape.m4 Tue Nov 14 06:19:04 2006 *************** include(iparm.m4)dnl *** 38,46 **** typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; ! /* The shape parameter is ignored. We can currently deduce the shape from the ! return array. */ ! dnl Only the kind (ie size) is used to name the function. extern void reshape_`'rtype_ccode (rtype *, rtype *, shape_type *, rtype *, shape_type *); --- 38,46 ---- typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; ! dnl For integer routines, only the kind (ie size) is used to name the ! dnl function. The same function will be used for integer and logical ! dnl arrays of the same kind. extern void reshape_`'rtype_ccode (rtype *, rtype *, shape_type *, rtype *, shape_type *); *************** reshape_`'rtype_ccode (rtype * ret, rtyp *** 79,84 **** --- 79,85 ---- const rtype_name *src; int n; int dim; + int sempty, pempty; if (source->dim[0].stride == 0) source->dim[0].stride = 1; *************** reshape_`'rtype_ccode (rtype * ret, rtyp *** 93,99 **** { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n=0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; --- 94,100 ---- { rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; rs = 1; ! for (n = 0; n < rdim; n++) { ret->dim[n].lbound = 0; rex = shape->data[n * shape->dim[0].stride]; *************** reshape_`'rtype_ccode (rtype * ret, rtyp *** 137,149 **** sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! abort (); if (ssize == sstride[n]) ssize *= sextent[n]; --- 138,154 ---- sdim = GFC_DESCRIPTOR_RANK (source); ssize = 1; + sempty = 0; for (n = 0; n < sdim; n++) { scount[n] = 0; sstride[n] = source->dim[n].stride; sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; if (sextent[n] <= 0) ! { ! sempty = 1; ! sextent[n] = 0; ! } if (ssize == sstride[n]) ssize *= sextent[n]; *************** reshape_`'rtype_ccode (rtype * ret, rtyp *** 155,167 **** { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! abort (); if (psize == pstride[n]) psize *= pextent[n]; else --- 160,177 ---- { pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; + pempty = 0; for (n = 0; n < pdim; n++) { pcount[n] = 0; pstride[n] = pad->dim[n].stride; pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; if (pextent[n] <= 0) ! { ! pempty = 1; ! pextent[n] = 0; ! } ! if (psize == pstride[n]) psize *= pextent[n]; else *************** reshape_`'rtype_ccode (rtype * ret, rtyp *** 173,178 **** --- 183,189 ---- { pdim = 0; psize = 1; + pempty = 1; pptr = NULL; } *************** reshape_`'rtype_ccode (rtype * ret, rtyp *** 190,195 **** --- 201,224 ---- rstride0 = rstride[0]; sstride0 = sstride[0]; + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Switch immediately to the pad array. */ + src = pptr; + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * sizeof (rtype_name); + } + } + while (rptr) { /* Select between the source and pad arrays. */ *************** reshape_`'rtype_ccode (rtype * ret, rtyp *** 199,204 **** --- 228,234 ---- src += sstride0; rcount[0]++; scount[0]++; + /* Advance to the next destination element. */ n = 0; while (rcount[n] == rextent[n]) diff -Nrcpad gcc-4.1.1/libgfortran/m4/specific.m4 gcc-4.1.2/libgfortran/m4/specific.m4 *** gcc-4.1.1/libgfortran/m4/specific.m4 Mon Oct 3 07:22:20 2005 --- gcc-4.1.2/libgfortran/m4/specific.m4 Mon Oct 2 09:37:09 2006 *************** define(get_typename2, `$1 (kind=$2)')dnl *** 6,12 **** define(get_typename, `get_typename2(ifelse($1,i,integer,ifelse($1,r,real,ifelse($1,l,logical,ifelse($1,c,complex,unknown)))),`$2')')dnl define(atype_name, get_typename(atype_letter,atype_kind))dnl define(name, regexp(regexp(file, `[^/]*$', `\&'), `^_\([^_]*\)_', `\1'))dnl ! define(function_name,`specific__'name`_'atype_code)dnl define(type,ifelse(atype_letter,l,LOGICAL,ifelse(atype_letter,i,INTEGER,ifelse(atype_letter,r,REAL,ifelse(atype_letter,c,COMPLEX,UNKNOW)))))dnl define(Q,ifelse(atype_kind,4,F,ifelse(atype_kind,8,`',ifelse(atype_kind,10,L,ifelse(atype_kind,16,L,`_'atype_kind)))))dnl --- 6,13 ---- define(get_typename, `get_typename2(ifelse($1,i,integer,ifelse($1,r,real,ifelse($1,l,logical,ifelse($1,c,complex,unknown)))),`$2')')dnl define(atype_name, get_typename(atype_letter,atype_kind))dnl define(name, regexp(regexp(file, `[^/]*$', `\&'), `^_\([^_]*\)_', `\1'))dnl ! define(rtype_name,get_typename(ifelse(name,abs,ifelse(atype_letter,c,r,atype_letter),atype_letter),atype_kind))dnl ! define(function_name,ifelse(name,conjg,`specific__conjg_'atype_kind,`specific__'name`_'atype_code))dnl define(type,ifelse(atype_letter,l,LOGICAL,ifelse(atype_letter,i,INTEGER,ifelse(atype_letter,r,REAL,ifelse(atype_letter,c,COMPLEX,UNKNOW)))))dnl define(Q,ifelse(atype_kind,4,F,ifelse(atype_kind,8,`',ifelse(atype_kind,10,L,ifelse(atype_kind,16,L,`_'atype_kind)))))dnl *************** ifelse(NEEDED,NONE,`',`#ifdef HAVE_'pref *** 33,39 **** elemental function function_name (parm) atype_name, intent (in) :: parm ! atype_name :: function_name function_name = name (parm) end function --- 34,40 ---- elemental function function_name (parm) atype_name, intent (in) :: parm ! rtype_name :: function_name function_name = name (parm) end function diff -Nrcpad gcc-4.1.1/libgfortran/runtime/error.c gcc-4.1.2/libgfortran/runtime/error.c *** gcc-4.1.1/libgfortran/runtime/error.c Thu Mar 23 06:07:32 2006 --- gcc-4.1.2/libgfortran/runtime/error.c Sat Nov 4 14:04:27 2006 *************** translate_error (int code) *** 435,440 **** --- 435,444 ---- p = "Write exceeds length of DIRECT access record"; break; + case ERROR_SHORT_RECORD: + p = "Short record on unformatted read"; + break; + default: p = "Unknown error code"; break; diff -Nrcpad gcc-4.1.1/libgfortran/runtime/normalize.c gcc-4.1.2/libgfortran/runtime/normalize.c *** gcc-4.1.1/libgfortran/runtime/normalize.c Wed Aug 17 02:49:08 2005 --- gcc-4.1.2/libgfortran/runtime/normalize.c Thu Jan 1 00:00:00 1970 *************** *** 1,120 **** - /* Nelper routines to convert from integer to real. - Copyright 2004, 2005 Free Software Foundation, Inc. - Contributed by Paul Brook. - - This file is part of the GNU Fortran 95 runtime library (libgfortran). - - Libgfortran is free software; you can redistribute it and/or - modify it under the terms of the GNU General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - In addition to the permissions in the GNU General Public License, the - Free Software Foundation gives you unlimited permission to link the - compiled version of this file into combinations with other programs, - and to distribute those combinations without any restriction coming - from the use of this file. (The General Public License restrictions - do apply in other respects; for example, they cover modification of - the file, and distribution when not linked into a combine - executable.) - - Ligbfortran is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public - License along with libgfortran; see the file COPYING. If not, - write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301, USA. */ - #include - #include "libgfortran.h" - - /* These routines can be sensitive to excess precision, so should really be - compiled with -ffloat-store. */ - - /* Return the largest value less than one representable in a REAL*4. */ - - static inline GFC_REAL_4 - almostone_r4 (void) - { - #ifdef HAVE_NEXTAFTERF - return nextafterf (1.0f, 0.0f); - #else - /* The volatile is a hack to prevent excess precision on x86. */ - static volatile GFC_REAL_4 val = 0.0f; - GFC_REAL_4 x; - - if (val != 0.0f) - return val; - - val = 0.9999f; - do - { - x = val; - val = (val + 1.0f) / 2.0f; - } - while (val > x && val < 1.0f); - if (val == 1.0f) - val = x; - return val; - #endif - } - - - /* Return the largest value less than one representable in a REAL*8. */ - - static inline GFC_REAL_8 - almostone_r8 (void) - { - #ifdef HAVE_NEXTAFTER - return nextafter (1.0, 0.0); - #else - static volatile GFC_REAL_8 val = 0.0; - GFC_REAL_8 x; - - if (val != 0.0) - return val; - - val = 0.9999; - do - { - x = val; - val = (val + 1.0) / 2.0; - } - while (val > x && val < 1.0); - if (val == 1.0) - val = x; - return val; - #endif - } - - - /* Convert an unsigned integer in the range [0..x] into a - real the range [0..1). */ - - GFC_REAL_4 - normalize_r4_i4 (GFC_UINTEGER_4 i, GFC_UINTEGER_4 x) - { - GFC_REAL_4 r; - - r = (GFC_REAL_4) i / (GFC_REAL_4) x; - if (r == 1.0f) - r = almostone_r4 (); - return r; - } - - - /* Convert an unsigned integer in the range [0..x] into a - real the range [0..1). */ - - GFC_REAL_8 - normalize_r8_i8 (GFC_UINTEGER_8 i, GFC_UINTEGER_8 x) - { - GFC_REAL_8 r; - - r = (GFC_REAL_8) i / (GFC_REAL_8) x; - if (r == 1.0) - r = almostone_r8 (); - return r; - } --- 0 ----