diff -Nrcpad gcc-4.3.3/gcc/fortran/ChangeLog gcc-4.4.0/gcc/fortran/ChangeLog *** gcc-4.3.3/gcc/fortran/ChangeLog Sat Jan 24 10:15:54 2009 --- gcc-4.4.0/gcc/fortran/ChangeLog Tue Apr 21 08:44:29 2009 *************** *** 1,1072 **** ! 2009-01-24 Release Manager ! ! * GCC 4.3.3 released. ! ! 2009-01-17 Paul Thomas ! ! PR fortran/38657 ! * module.c (write_common_0): Revert patch of 2009-01-10. ! ! 2009-01-14 Mikael Morin ! ! PR fortran/35681 ! * ChangeLog: Fix function name. ! ! PR fortran/38487 ! * dependency.c (gfc_check_argument_var_dependency): ! Move the check for pointerness inside the if block ! so that it doesn't affect the return value. ! ! PR fortran/38669 ! * trans-stmt.c (gfc_trans_call): ! Add the dependency code after the loop bounds calculation one. ! ! 2009-01-11 Paul Thomas ! ! PR fortran/38763 ! Backport from mainline: ! * target-memory.c (encode_derived): Encode NULL. ! ! PR fortran/38765 ! Backport from mainline: ! * resolve.c (check_host_association): Use the symtree name to ! search for a potential contained procedure, since this is the ! name by which it would be referenced. ! ! 2009-01-10 Paul Thomas ! ! PR fortran/38657 ! * module.c (write_common_0): Use the name of the symtree rather ! than the common block, to determine if the common has been ! written. ! ! 2009-01-10 Paul Thomas ! ! PR fortran/38665 ! * gfortran.h : Add bit to gfc_expr 'user_operator' ! * interface.c (gfc_extend_expr): Set the above if the operator ! is substituted by a function. ! * resolve.c (check_host_association): Return if above is set. ! ! 2009-01-01 John David Anglin ! ! PR fortran/38675 ! Backport from mainline: ! 2008-12-09 Mikael Morin ! ! PR fortran/37469 ! * expr.c (find_array_element): Simplify array bounds. ! Assert that both bounds are constant expressions. ! ! 2008-10-31 Mikael Morin ! ! * expr.c (gfc_reduce_init_expr): New function, containing checking code ! from gfc_match_init_expr, so that checking can be deferred. ! (gfc_match_init_expr): Use gfc_reduce_init_expr. ! * match.h (gfc_reduce_init_expr): Prototype added. ! ! 2008-12-22 Paul Thomas ! ! PR fortran/38602 ! * trans-decl.c (init_intent_out_dt): Allow for optional args. ! ! 2008-12-21 Mikael Morin ! ! PR fortran/38487 ! * dependency.c (gfc_is_data_pointer): New function. ! (gfc_check_argument_var_dependency): Disable the warning ! in the pointer case. ! (gfc_check_dependency): Use gfc_is_data_pointer. ! ! 2008-12-21 Mikael Morin ! ! PR fortran/38113 ! * error.c (show_locus): Start counting columns at 0. ! * primary.c (match_actual_arg): Eat spaces ! before copying the current locus. ! (match_variable): Copy the locus before matching. ! ! 2008-12-21 Mikael Morin ! ! PR fortran/35983 ! * trans-expr.c (gfc_trans_subcomponent_assign): ! Add se's pre and post blocks to current block. ! (gfc_trans_structure_assign): Remove specific handling ! of C_NULL_PTR and C_NULL_FUNPTR. ! ! 2008-12-14 Paul Thomas ! ! PR fortran/35937 ! * trans-expr.c (gfc_finish_interface_mapping): Fold convert the ! character length to gfc_charlen_type_node. ! ! 2008-12-04 Janis Johnson ! ! Backport from mainline: ! 2008-10-18 Jakub Jelinek ! Janis Johnson ! ! * Make-lang.in (check-f95-subtargets, check-fortran-subtargets): New ! aliases for check-gfortran-subtargets. ! (lang_checks_parallelized): Add check-gfortran. ! (check_gfortran_parallelize): New variable. ! ! 2008-11-24 Paul Thomas ! ! PR fortran/34820 ! * trans-expr.c (gfc_conv_function_call): Remove all code to ! deallocate intent out derived types with allocatable ! components. ! (gfc_trans_assignment_1): An assignment from a scalar to an ! array of derived types with allocatable components, requires ! a deep copy to each array element and deallocation of the ! converted rhs expression afterwards. ! * trans-array.c : Minor whitespace. ! * trans-decl.c (init_intent_out_dt): Add code to deallocate ! allocatable components of derived types with intent out. ! (generate_local_decl): If these types are unused, set them ! referenced anyway but allow the uninitialized warning. ! ! PR fortran/34143 ! * trans-expr.c (gfc_trans_subcomponent_assign): If a conversion ! expression has a null data pointer argument, nullify the ! allocatable component. ! ! PR fortran/32795 ! * trans-expr.c (gfc_trans_subcomponent_assign): Only nullify ! the data pointer if the source is not a variable. ! ! 2008-11-29 Paul Thomas ! ! PR fortran/37735 ! * trans-array.c (structure_alloc_comps): Do not duplicate the ! descriptor if this is a descriptorless array! ! ! 2008-11-27 Paul Thomas ! ! PR fortran/36526 ! * interface.c (check_intents): Correct error where the actual ! arg was checked for a pointer argument, rather than the formal. ! ! 2008-11-24 Paul Thomas ! ! PR fortran/38033 ! * trans-array.c (gfc_trans_create_temp_array): Stabilize the ! 'to' expression. ! (gfc_conv_loop_setup): Use the end expression for the loop 'to' ! if it is available. ! ! 2008-11-24 Paul Thomas ! ! PR fortran/37926 ! * trans-expr.c (gfc_free_interface_mapping): Null sym->formal ! (gfc_add_interface_mapping): Copy the pointer to the formal ! arglist and set attr.always_explicit if this is a procedure. ! ! 2008-11-24 Steven G. Kargl ! ! PR fortran/37792 ! * fortran/resolve.c (resolve_fl_variable): Simplify the ! initializer if there is one. ! ! 2008-11-24 Mikael Morin ! ! PR fortran/35681 ! * dependency.c (gfc_check_argument_var_dependency): Add ! elemental check flag. Issue a warning if we find a dependency ! but don't generate a temporary. Add the case of an elemental ! function call as actual argument to an elemental procedure. ! Add the case of an operator expression as actual argument ! to an elemental procedure. ! (gfc_check_argument_dependency): Add elemental check flag. ! Update calls to gfc_check_argument_var_dependency. ! (gfc_check_fncall_dependency): Add elemental check flag. ! Update call to gfc_check_argument_dependency. ! * trans-stmt.c (gfc_trans_call): Make call to ! gfc_conv_elemental_dependencies unconditional, but with a flag ! whether we should check dependencies between variables. ! (gfc_conv_elemental_dependencies): Add elemental check flag. ! Update call to gfc_check_fncall_dependency. ! * trans-expr.c (gfc_trans_arrayfunc_assign): Update call to ! gfc_check_fncall_dependency. ! * resolve.c (find_noncopying_intrinsics): Update call to ! gfc_check_fncall_dependency. ! * dependency.h (enum gfc_dep_check): New enum. ! (gfc_check_fncall_dependency): Update prototype. ! ! 2008-11-19 Paul Thomas ! ! PR fortran/38171 ! * module.c (load_equiv): Regression fix; check that equivalence ! members come from the same module only. ! ! 2008-11-14 Paul Thomas ! ! PR fortran/37836 ! * intrinsic.c (add_functions): Reference gfc_simplify._minval ! and gfc_simplify_maxval. ! * intrinsic.h : Add prototypes for gfc_simplify._minval and ! gfc_simplify_maxval. ! * simplify.c (min_max_choose): New function extracted from ! simplify_min_max. ! (simplify_min_max): Call it. ! (simplify_minval_maxval, gfc_simplify_minval, ! gfc_simplify_maxval): New functions. ! ! 2008-11-08 Paul Thomas ! ! PR fortran/37597 ! * parse.c (gfc_fixup_sibling_symbols ): Fixup contained, even ! when symbol not found. ! ! 2008-11-08 Mikael Morin ! ! PR fortran/35820 ! * resolve.c (gfc_count_forall_iterators): New function. ! (gfc_resolve_forall): Use gfc_count_forall_iterators to evaluate ! the needed memory amount to allocate. Don't forget to free allocated ! memory. Add an assertion to check for memory leaks. ! ! 2008-11-08 Paul Thomas ! ! PR fortran/37445 ! * resolve.c (resolve_call): Check host association is correct. ! (resolve_actual_arglist ): Remove return is old_sym is use ! associated. Only reparse expression if old and new symbols ! have different types. ! ! PR fortran/PR35769 ! * resolve.c (gfc_resolve_assign_in_forall): Change error to a ! warning. ! ! 2008-11-01 Mikael Morin ! ! PR fortran/37903 ! * trans-array.c (gfc_trans_create_temp_array): If n is less ! than the temporary dimension, assert that loop->from is ! zero (reverts to earlier versions). If there is at least one ! null loop->to[n], it is a callee allocated array so set the ! size to NULL and break. ! (gfc_trans_constant_array_constructor): Set the offset to zero. ! (gfc_trans_array_constructor): Remove loop shifting around the ! temporary creation. ! (gfc_conv_loop_setup): Prefer zero-based descriptors if ! possible. Calculate the translation from loop variables to ! array indices if an array constructor. ! ! 2008-11-01 Mikael Morin ! ! PR fortran/37749 ! * trans-array.c (gfc_trans_create_temp_array): If size is NULL ! use the array bounds for loop->to. ! ! 2008-10-19 Paul Thomas ! ! PR fortran/37723 ! * dependency.c (gfc_dep_resolver ): If we find equal array ! element references, go on to the next reference. ! ! 2008-10-19 Paul Thomas ! ! PR fortran/37787 ! * dependency.c (gfc_are_equivalenced_arrays): Look in symbol ! namespace rather than current namespace, if it is available. ! ! 2008-10-11 Paul Thomas ! ! PR fortran/37794 ! * module.c (check_for_ambiguous): Remove redundant code. ! ! 2008-10-11 Paul Thomas ! ! PR fortran/35680 ! * gfortran.h : Add 'error' bit field to gfc_expr structure. ! * expr.c (check_inquiry): When checking a restricted expression ! check that arguments are either variables or restricted. ! (check_restricted): Do not emit error if the expression has ! 'error' set. Clean up detection of host-associated variable. ! ! 2008-10-05 Paul Thomas ! ! PR fortran/37706 ! * module.c (load_equiv): Check the module before negating the ! unused flag. ! ! 2008-09-26 Tobias Burnus ! ! PR fortran/37580 ! * expr.c (gfc_check_pointer_assign): Add checks for pointer ! remapping. ! ! 2008-09-26 Tobias Burnus ! ! PR fortran/37504 ! * expr.c (gfc_check_pointer_assign): Allow assignment of ! protected pointers. ! ! 2008-09-25 Tobias Burnus ! ! PR fortran/37626 ! * trans-array.c (gfc_trans_deferred_array): Don't auto-deallocate ! result variable. ! ! 2008-09-24 Paul Thomas ! ! PR fortran/35945 ! * resolve.c (resolve_fl_variable_derived): Remove derived type ! comparison for use associated derived types. Host association ! of a derived type will not arise if there is a local derived type ! whose use name is the same. ! ! PR fortran/36700 ! * match.c (gfc_match_call): Use the existing symbol even if ! it is a function. ! ! 2008-09-24 Paul Thomas ! ! PR fortran/37583 ! * decl.c (gfc_match_entry): Both subroutines and functions can ! give a true for get_proc_mame's last argument so remove the ! && gfc_current_ns->proc_name->attr.function. ! resolve.c (resolve_actual_arglist): Add check for recursion by ! reference to procedure as actual argument. ! ! 2008-09-23 Paul Thomas ! ! PR fortran/37274 ! PR fortran/36374 ! * module.c (check_for_ambiguous): New function to test loaded ! symbol for ambiguity with fixup symbol. ! (read_module): Call check_for_ambiguous. ! (write_symtree): Do not write the symtree for symbols coming ! from an interface body. ! ! PR fortran/36374 ! * resolve.c (count_specific_procs ): New function to count the ! number of specific procedures with the same name as the generic ! and emit appropriate errors for and actual argument reference. ! (resolve_assumed_size_actual): Add new argument no_formal_args. ! Correct logic around passing generic procedures as arguments. ! Call count_specific_procs from two locations. ! (resolve_function): Evaluate and pass no_formal_args. ! (resolve call): The same and clean up a bit by using csym more ! widely. ! ! PR fortran/36454 ! * symbol.c (gfc_add_access): Access can be updated if use ! associated and not private. ! ! 2008-09-13 Daniel Kraft ! ! PR fortran/35770 ! * primary.c (gfc_match_varspec): Added missing type-spec clearing ! after wrong implicit character typing. ! ! 2008-09-11 Daniel Kraft ! ! PR fortran/36214 ! * simplify.c (simplify_cmplx): Added linebreak to long line. ! * target-memory.c (gfc_convert_boz): Fix indentation. ! (gfc_interpret_float): Set mpfr precision to right value before ! calling mpfr_init. ! ! 2008-09-08 Daniel Kraft ! ! PR fortran/37199 ! * trans-expr.c (gfc_add_interface_mapping): Set new_sym->as. ! (gfc_map_intrinsic_function): Added checks against NULL bounds in ! array specs. ! ! 2008-09-05 Daniel Kraft ! ! PR fortran/35837 ! * resolve.c (resolve_types): Restore gfc_current_ns on exit. ! * symbol.c (gfc_save_all): Removed blank line. ! ! 2008-09-04 Daniel Kraft ! ! * PR fortran/37099 ! * expr.c (simplify_const_ref): Update expression's character length ! when pulling out a substring reference. ! ! 2008-08-30 Daniel Kraft ! ! PR fortran/37193 ! * module.c (read_module): Initialize use_only flag on used symbols. ! ! 2008-06-24 Paul Thomas ! ! PR fortran/36371 ! * expr.c (gfc_check_assign): Change message and locus for ! error when conform == 0. ! ! 2008-08-27 Release Manager ! ! * GCC 4.3.2 released. ! ! 2008-07-27 Tobias Burnus ! ! PR fortran/36132 ! ! * trans-array.c (gfc_conv_array_parameter): Fix packing/unpacking ! for nonpresent optional actuals to optional formals. ! * trans-array.h (gfc_conv_array_parameter): Update declaration. ! * trans-expr.c (gfc_conv_function_call,gfc_trans_arrayfunc_assign): ! Update gfc_conv_array_parameter calls. ! * trans-intrinsics (gfc_conv_intrinsic_transfer, ! gfc_conv_intrinsic_loc): Ditto. ! ! 2008-07-19 Paul Thomas ! ! PR fortran/36366 ! * resolve.c (add_dt_to_dt_list): New function. ! (resolve_fl_derived): Call new function for pointer components ! and when derived type resolved. ! ! 2008-07-17 Tobias Burnus ! ! PR fortran/36824 ! * resolve.c (resolve_fl_derived): Fix constantness check ! for the array dimensions. ! ! 2008-06-20 Laurynas Biveinis ! Tobias Burnus ! ! PR fortran/34908 ! PR fortran/36276 ! * scanner.c (preprocessor_line): do not call gfc_free for ! current_file->filename if it differs from filename. ! ! 2008-06-06 Release Manager ! ! * GCC 4.3.1 released. ! ! 2008-05-18 Francois-Xavier Coudert ! PR fortran/36176 ! * target-memory.c (gfc_target_expr_size): Correctly treat ! substrings. ! (gfc_target_encode_expr): Likewise. ! (gfc_interpret_complex): Whitespace change. ! 2008-05-17 Jerry DeLisle ! Backport from mainline: ! PR fortran/35184 ! * trans-array.c (gfc_conv_array_index_offset): Remove ! unnecessary assert. ! 2008-05-17 Paul Thomas Backport from mainline: ! PR fortran/35756 ! PR fortran/35759 ! * trans-stmt.c (gfc_trans_where): Tighten up the dependency ! check for calling gfc_trans_where_3. ! ! PR fortran/35743 ! * trans-stmt.c (gfc_trans_where_2): Set the mask size to zero ! if it is calculated to be negative. ! ! PR fortran/35745 ! * trans-stmt.c (gfc_trans_where_3, gfc_trans_where_assign): Set ! ss->where for scalar right hand sides. ! * trans-array.c (gfc_add_loop_ss_code): If ss->where is set do ! not evaluate scalars outside the loop. Clean up whitespace. ! * trans.h : Add a bitfield 'where' to gfc_ss. ! ! PR fortran/36233 ! * interface.c (compare_actual_formal): Do not check sizes if the ! actual is BT_PROCEDURE. ! ! 2008-05-13 Paul Thomas ! ! PR fortran/35997 ! * module.c (find_symbol): Do not return a result for a symbol ! that has been renamed in another module. ! ! 2008-05-01 Paul Thomas ! ! PR fortran/35864 ! * expr.c (scalarize_intrinsic_call): Reorder identification of ! array argument so that if one is not found a segfault does not ! occur. Return FAILURE if all scalar arguments. ! ! PR fortran/35780 ! * expr.c (scalarize_intrinsic_call): Identify which argument is ! an array and use that as the template. ! (check_init_expr): Remove tests that first argument is an array ! in the call to scalarize_intrinsic_call. ! ! 2008-04-26 Jerry DeLisle ! Francois-Xavier Coudert ! PR fortran/35994 ! * trans-instrinsic.c (gfc_conv_intrinsic_minmaxloc): ! Correctly adjust loop counter offset. ! 2008-04-19 Paul Thomas ! PR fortran/35944 ! PR fortran/35946 ! PR fortran/35947 ! * trans_array.c (gfc_trans_array_constructor): Temporarily ! realign loop, if loop->from is not zero, before creating ! the temporary array and provide an offset. ! PR fortran/35959 ! * trans-decl.c (gfc_init_default_dt): Add gfc_ prefix to name ! and allow for NULL body. Change all references from ! init_default_dt to gfc_init_default_dt. ! * trans.h : Add prototype for gfc_init_default_dt. ! * trans-array.c (gfc_trans_deferred_vars): After nullification ! call gfc_init_default_dt for derived types with allocatable ! components. ! 2008-04-18 Jerry DeLisle ! PR fortran/35724 ! * iresolve.c (gfc_resolve_eoshift): Check for NULL symtree in ! test for optional argument attribute. ! 2008-04-16 Paul Thomas ! PR fortran/35932 ! * trans-intrinsic.c (gfc_conv_intrinsic_char): Even though KIND ! is not used, the argument must be converted. ! 2008-04-16 Jakub Jelinek ! PR target/35662 ! * f95-lang.c (gfc_init_builtin_functions): Make sure ! BUILT_IN_SINCOS{,F,L} types aren't varargs. ! 2008-04-03 Jakub Jelinek ! PR fortran/35786 ! * openmp.c (resolve_omp_clauses): Diagnose if a clause symbol ! isn't a variable. ! 2008-04-01 Joseph Myers ! * gfortran.texi: Include gpl_v3.texi instead of gpl.texi ! * Make-lang.in (GFORTRAN_TEXI): Include gpl_v3.texi instead of ! gpl.texi. ! 2008-03-30 Paul Thomas ! PR fortran/35740 ! * resolve.c (resolve_function, resolve_call): If the procedure ! is elemental do not look for noncopying intrinsics. ! 2008-03-29 Paul Thomas ! PR fortran/35698 ! * trans-array.c (gfc_array_init_size): Set 'size' zero if ! negative in one dimension. ! PR fortran/35702 ! * trans-expr.c (gfc_trans_string_copy): Only assign a char ! directly if the lhs and rhs types are the same. ! 2008-03-27 Jerry DeLisle ! PR fortran/35724 ! * iresolve.c (gfc_resolve_cshift): Check for NULL symtree in ! test for optional argument attribute. ! 2008-03-24 Paul Thomas ! PR fortran/34813 ! * resolve.c (resolve_structure_cons): It is an error to assign ! NULL to anything other than a pointer or allocatable component. ! PR fortran/33295 ! * resolve.c (resolve_symbol): If the symbol is a derived type, ! resolve the derived type. If the symbol is a derived type ! function, ensure that the derived type is visible in the same ! namespace as the function. ! 2008-03-14 Paul Thomas ! PR fortran/35474 ! * module.c (mio_symtree_ref): After providing a symbol for a ! missing equivalence member, resolve and NULL the fixups. ! 2008-03-05 Release Manager ! * GCC 4.3.0 released. ! 2008-03-02 Jakub Jelinek * gfortranspec.c (lang_specific_driver): Update copyright notice dates. ! 2008-02-28 Uros Bizjak ! ! Backport from mainline: ! 2008-02-25 Francois-Xavier Coudert ! ! PR target/25477 ! * trans-expr.c (gfc_conv_power_op): Use BUILT_IN_CPOW{F,,L}. ! * f95-lang.c (gfc_init_builtin_functions): Define BUILT_IN_CPOW{F,,L}. ! * trans.h (gfor_fndecl_math_cpow, gfor_fndecl_math_cpowf, ! gfor_fndecl_math_cpowl10, gfor_fndecl_math_cpowl16): Remove. ! * trans-decl.c: Likewise. ! ! 2008-02-16 Francois-Xavier Coudert ! ! PR fortran/34952 ! * gfortran.texi: Create new section for unimplemented extensions. ! Add "STRUCTURE and RECORD" and "ENCODE and DECODE statements". ! Remove "smaller projects" list. Fix a few typos. ! ! 2008-02-15 Francois-Xavier Coudert ! ! * intrinsic.texi: Rename INDEX node to avoid clashing with ! index.html on case-insensitive systems. ! ! 2008-02-15 Francois-Xavier Coudert ! ! PR fortran/35150 ! * trans-expr.c (gfc_conv_function_call): Force evaluation of ! se->expr. ! ! 2008-02-10 Daniel Franke ! ! fortran/PR35019 ! * lang.opt: Allow '-J' next to '-J ', ! likewise '-I ' and '-I'. ! ! 2008-02-06 Kaveh R. Ghazi ! ! PR other/35107 ! * Make-lang.in (f951): Add $(GMPLIBS). ! ! 2008-02-05 Francois-Xavier Coudert ! ! PR fortran/35037 ! * trans-common.c (build_field): Mark fields as volatile when needed. ! ! 2008-02-05 Tobias Burnus ! ! PR fortran/35093 ! * data.c (gfc_assign_data_value): Only free "size" if ! it has not already been freed. ! ! 2008-02-05 Paul Thomas ! ! PR fortran/34945 ! * array.c (match_array_element_spec): Remove check for negative ! array size. ! (gfc_resolve_array_spec): Add check for negative size. ! ! 2008-02-05 Paul Thomas ! ! PR fortran/32315 ! * data.c (gfc_assign_data_value): Add bounds check for array ! references. ! ! 2008-02-04 Daniel Franke ! ! * resolve.c (resolve_where): Fix typo. ! (gfc_resolve_where_code_in_forall): Likewise. ! ! 2008-02-03 Paul Thomas ! ! PR fortran/32760 ! * resolve.c (resolve_allocate_deallocate): New function. ! (resolve_code): Call it for allocate and deallocate. ! * match.c (gfc_match_allocate, gfc_match_deallocate) : Remove ! the checking of the STAT tag and put in above new function. ! * primary,c (match_variable): Do not fix flavor of host ! associated symbols yet if the type is not known. ! ! 2008-01-31 Paul Thomas ! ! PR fortran/34910 ! * expr.c (gfc_check_assign): It is an error to assign ! to a sibling procedure. ! ! 2008-01-30 Paul Thomas ! ! PR fortran/34975 ! * symbol.c (gfc_delete_symtree, gfc_undo_symbols): Rename ! delete_symtree to gfc_delete_symtree. ! * gfortran.h : Add prototype for gfc_delete_symtree. ! * module.c (load_generic_interfaces): Transfer symbol to a ! unique symtree and delete old symtree, instead of renaming. ! (read_module): The rsym and the found symbol are the same, so ! the found symtree can be deleted. ! ! PR fortran/34429 ! * decl.c (match_char_spec): Remove the constraint on deferred ! matching of functions and free the length expression. ! delete_symtree to gfc_delete_symtree. ! (gfc_match_type_spec): Whitespace. ! (gfc_match_function_decl): Defer characteristic association for ! all types except BT_UNKNOWN. ! * parse.c (decode_specification_statement): Only derived type ! function matching is delayed to the end of specification. ! ! 2008-01-28 Tobias Burnus ! ! PR libfortran/34980 ! * simplify.c (gfc_simplify_shape): Simplify rank zero arrays. ! ! 2008-01-27 Jerry DeLisle ! ! PR fortran/34990 ! * array.c (gfc_check_constructor_type): Revert clearing the expression. ! ! 2008-01-26 Tobias Burnus ! ! PR fortran/34848 ! * trans-expr.c (gfc_conv_function_call): Don't call ! gfc_add_interface_mapping if the expression is NULL. ! ! 2008-01-26 Jerry DeLisle ! ! PR fortran/31610 ! * trans-array.c (gfc_trans_create_temp_array): Remove call to ! gcc_assert (integer_zerop (loop->from[n])). ! ! 2008-01-25 Daniel Franke ! ! PR fortran/34661 ! * resolve.c (resolve_where): Added check if user-defined assignment ! operator is an elemental subroutine. ! (gfc_resolve_where_code_in_forall): Likewise. ! ! 2008-01-24 Daniel Franke ! ! PR fortran/33375 ! PR fortran/34858 ! * gfortran.h: Revert changes from 2008-01-17. ! * match.c: Likewise. ! * symbol.c: Likewise. ! (gfc_undo_symbols): Undo namespace changes related to common blocks. ! ! 2008-01-24 Daniel Franke ! ! PR fortran/34202 ! * data.c (formalize_structure_cons): Skip formalization on ! empty structures. ! ! 2008-01-24 Daniel Franke ! ! * gfortran.texi (OpenMP): Extended existing documentation. ! (contributors): Added major contributors of 2008 that were ! not listed yet. ! (proposed extensions): Removed implemented items. ! ! 2008-01-24 Paul Thomas ! ! PR fortran/34872 ! * parse.c (next_statement) : If ST_GET_FCN_CHARACTERISTICS is ! seen, check for a statement label and, if present, delete it ! and set the locus to the start of the statement. ! ! 2008-01-22 Paul Thomas ! ! PR fortran/34875 ! * trans-io.c (gfc_trans_transfer): If the array reference in a ! read has a vector subscript, use gfc_conv_subref_array_arg to ! copy back the temporary. ! ! 2008-01-22 Tobias Burnus ! ! PR fortran/34848 ! * interface.c (compare_actual_formal): Fix adding type ! to missing_arg_type for absent optional arguments. ! ! 2008-01-22 Tobias Burnus ! ! PR fortran/34907 ! * parse.c (parse_spec): Change = into ==. ! ! 2008-01-22 Daniel Franke ! ! PR fortran/34915 ! * expr.c (check_elemental): Fix check for valid data types. ! ! 2008-01-22 Tobias Burnus ! ! PR fortran/34899 ! * scanner.c (load_line): Support continuation lines. ! * invoke.texi (-Wtabs): Document this. ! ! 2008-01-22 Paul Thomas ! ! PR fortran/34896 ! * module.c (read_module): Set use_rename attribute. ! ! 2007-01-21 Tobias Burnus ! ! PR fortran/34901 ! * interface.c (compare_parameter): Improved error message ! for arguments of same type and mismatched kinds. ! ! 2008-01-20 Paul Thomas ! ! PR fortran/34861 ! * resolve.c (resolve_entries): Do not do an array bounds check ! if the result symbols are the same. ! ! PR fortran/34854 ! * module.c (read_module) : Hide the symtree of the previous ! version of the symbol if this symbol is renamed. ! ! 2008-01-20 Paul Thomas ! ! PR fortran/34784 ! * array.c (gfc_check_constructor_type): Clear the expression ts ! so that the checking starts from the deepest level of array ! constructor. ! * primary.c (match_varspec): If an unknown type is changed to ! default character and the attempt to match a substring fails, ! change it back to unknown. ! ! PR fortran/34785 ! * trans-array.c (gfc_add_loop_ss_code) : If ss->string_length is ! NULL for an array constructor, use the cl.length expression to ! build it. ! (gfc_conv_array_parameter): Change call to gfc_evaluate_now to ! a tree assignment. ! ! 2008-01-19 Thomas Koenig ! ! PR fortran/34817 ! PR fortran/34838 ! * iresolve.c (gfc_resolve_all): Remove conversion of mask ! argument to kind=1 by removing call to resolve_mask_arg(). ! (gfc_resolve_any): Likewise. ! ! 2008-01-19 Tobias Burnus ! ! PR fortran/34760 ! * primary.c (match_variable): Handle FL_UNKNOWN without ! uneducated guessing. ! (match_variable): Improve error message. ! ! 2008-01-18 Tobias Burnus ! ! PR fortran/32616 ! * interface.c (get_expr_storage_size): Return storage size ! for array element designators. ! (compare_actual_formal): Reject unequal string sizes for ! assumed-shape dummy arguments. And fix error message for ! array-sections with vector subscripts. ! ! 2008-01-17 Jerry DeLisle ! ! PR fortran/34556 ! * simplify.c (is_constant_array_expr): New static function that returns ! true if the given expression is an array and is constant. ! (gfc_simplify_reshape): Use new function. ! ! 2008-01-17 H.J. Lu ! ! PR fortran/33375 ! * symbol.c (free_common_tree): Renamed to ... ! (gfc_free_common_tree): This. Remove static. ! (gfc_free_namespace): Updated. ! ! * gfortran.h (gfc_free_common_tree): New. ! ! * match.c (gfc_match_common): Call gfc_free_common_tree () with ! gfc_current_ns->common_root and set gfc_current_ns->common_root ! to NULL on syntax error. ! ! 2008-01-18 Richard Sandiford ! ! PR fortran/34686 ! * trans-expr.c (gfc_conv_function_call): Use proper ! type for returned character pointers. ! 2008-01-17 Paul Thomas ! PR fortran/34429 ! PR fortran/34431 ! PR fortran/34471 ! * decl.c : Remove gfc_function_kind_locus and ! gfc_function_type_locus. Add gfc_matching_function. ! (match_char_length): If matching a function and the length ! does not match, return MATCH_YES and try again later. ! (gfc_match_kind_spec): The same. ! (match_char_kind): The same. ! (gfc_match_type_spec): The same for numeric and derived types. ! (match_prefix): Rename as gfc_match_prefix. ! (gfc_match_function_decl): Except for function valued character ! lengths, defer applying kind, type and charlen info until the ! end of specification block. ! gfortran.h (gfc_statement): Add ST_GET_FCN_CHARACTERISTICS. ! parse.c (decode_specification_statement): New function. ! (decode_statement): Call it when a function has kind = -1. Set ! and reset gfc_matching function, as function statement is being ! matched. ! (match_deferred_characteristics): Simplify with a single call ! to gfc_match_prefix. Do appropriate error handling. In any ! case, make sure that kind = -1 is reset or corrected. ! (parse_spec): Call above on seeing ST_GET_FCN_CHARACTERISTICS. ! Throw an error if kind = -1 after last specification statement. ! parse.h : Prototype for gfc_match_prefix. ! 2008-01-16 Tobias Burnus ! PR fortran/34796 ! * interface.c (compare_parameter): Allow AS_DEFERRED array ! elements and reject attr.pointer array elemenents. ! (get_expr_storage_size): Return storage size of elements of ! assumed-shape and pointer arrays. ! 2008-01-15 Sebastian Pop ! * f95-lang.c (gfc_init_builtin_functions): Initialize GOMP builtins ! for flag_tree_parallelize_loops. ! 2008-01-15 Thomas Koenig ! PR libfortran/34671 ! * iresolve.c (gfc_resolve_all): Call resolve_mask_arg. ! (gfc_resolve_any): Likewise. ! (gfc_resolve_count): Likewise. Don't append kind of ! argument to function name. ! 2008-01-13 Tobias Burnus ! PR fortran/34665 ! * resolve.c (resolve_actual_arglist): For expressions, ! also check for assume-sized arrays. ! * interface.c (compare_parameter): Move F2003 character checks ! here, print error messages here, reject elements of ! assumed-shape array as argument to dummy arrays. ! (compare_actual_formal): Update for the changes above. ! 2008-01-13 Tobias Burnus ! PR fortran/34763 ! * decl.c (contained_procedure): Only check directly preceeding state. ! 2008-01-13 Tobias Burnus ! PR fortran/34759 ! * check.c (gfc_check_shape): Accept array ranges of ! assumed-size arrays. ! 2008-01-12 Jerry DeLisle ! PR fortran/34432 ! * match.c (gfc_match_name): Don't error if leading character is a '(', ! just return MATCH_NO. ! 2008-01-11 Jerry DeLisle ! PR fortran/34722 ! * trans-io.c (create_dummy_iostat): Commit the symbol. ! 2008-01-11 Paul Thomas ! PR fortran/34537 ! * simplify.c (gfc_simplify_transfer): Return NULL if the size ! of the element is unavailable and only assign character length ! to the result, if 'mold' is constant. ! 2008-01-10 Paul Thomas ! PR fortran/34396 ! * trans-array.c (gfc_trans_array_ctor_element): Use gfc_trans_string_copy ! to assign strings and perform bounds checks on the string length. ! (get_array_ctor_strlen): Remove bounds checking. ! (gfc_trans_array_constructor): Initialize string length checking. ! * trans-array.h : Add prototype for gfc_trans_string_copy. ! 2008-01-08 Richard Guenther ! PR fortran/34706 ! PR tree-optimization/34683 ! * trans-types.c (gfc_get_array_type_bounds): Use an array type ! with known size for accesses if that is known. ! 2008-01-08 Paul Thomas ! PR fortran/34476 ! * expr.c (find_array_element): Check that the array bounds are ! constant before using them. Use lower, as well as upper bound. ! (check_restricted): Allow implied index variable. ! 2008-01-08 Paul Thomas ! PR fortran/34681 ! * trans_array.c (gfc_trans_deferred_array): Do not null the ! data pointer on entering scope, nor deallocate it on leaving ! scope, if the symbol has the 'save' attribute. ! PR fortran/34704 ! * trans_decl.c (gfc_finish_var_decl): Derived types with ! allocatable components and an initializer must be TREE_STATIC. ! 2008-01-07 Paul Thomas ! PR fortran/34672 ! * module.c (write_generic): Rewrite completely. ! (write_module): Change call to write_generic. ! 2008-01-06 Jerry DeLisle ! PR fortran/34659 ! * scanner.c (load_line): Do not count ' ' as printable when checking for ! continuations. ! 2008-01-06 Paul Thomas ! PR fortran/34545 ! * module.c (load_needed): If the namespace has no proc_name ! give it the module symbol. ! 2008-01-06 Jerry DeLisle ! PR fortran/34387 ! * trans-expr.c (gfc_conv_missing_dummy): Use a temporary to type convert ! the dummy variable expression, test for NULL, and pass the variable ! address to the called function. ! 2007-01-06 Tobias Burnus ! PR fortran/34658 ! * match.c (gfc_match_common): Remove blank common in ! DATA BLOCK warning. ! * resolve.c (resolve_common_vars): New function. ! (resolve_common_blocks): Move checks to resolve_common_vars ! and invoke that function. ! (resolve_types): Call resolve_common_vars for blank commons. ! 2008-01-06 Tobias Burnus ! PR fortran/34655 ! * resolve.c (resolve_equivalence_derived): Reject derived types with ! default initialization if equivalenced with COMMON variable. ! 2008-01-06 Tobias Burnus ! PR fortran/34654 ! * io.c (check_io_constraints): Disallow unformatted I/O for ! internal units. ! 2008-01-06 Tobias Burnus ! PR fortran/34660 ! * resolve.c (resolve_formal_arglist): Reject dummy procedure in ! ELEMENTAL functions. ! 2008-01-06 Tobias Burnus ! PR fortran/34662 ! * interface.c (compare_actual_formal): Reject parameter ! actual to intent(out) dummy. ! 2008-01-04 Tobias Burnus ! PR fortran/34557 ! * primary.c (match_varspec): Gobble whitespace before ! checking for '('. --- 1,274 ---- ! 2009-04-21 Release Manager ! * GCC 4.4.0 released. ! 2009-04-08 Janus Weil ! PR fortran/38152 ! * trans-decl.c (gfc_get_symbol_decl): Correctly set decl location for ! procedure pointer decls. ! 2009-04-04 Paul Thomas Backport from mainline: ! PR fortran/39519 ! * parse.c (parse_derived): Do not break on finding pointer, ! allocatable or private components. ! 2009-04-03 Tobias Burnus ! PR fortran/39594 ! * resolve.c (resolve_common_vars): Add FL_VARIABLE to symbol ! if it is not a procedure pointer. ! * primary.c (match_actual_arg): Ditto. ! 2009-03-30 Jakub Jelinek ! * trans-types.c (gfc_sym_type, gfc_return_by_reference): For ! sym->attr.result check sym->ns->proc_name->attr.is_bind_c. ! 2009-03-18 Ralf Wildenhues ! * lang.opt: Unify help texts for -I, -Wconversion, -d, -fopenmp, ! and -fpreprocessed. ! 2009-03-06 Alexandre Oliva ! * simplify.c (gfc_simplify_transfer): Zero-initialize the ! buffer. ! 2009-02-27 Tobias Burnus ! PR fortran/39309 ! * module.c (read_md5_from_module_file): Add missing quote. ! 2009-02-27 Tobias Burnus ! PR fortran/39309 ! * module.c (read_md5_from_module_file): Include mod version ! in had-changed test. ! 2009-02-26 Paul Thomas ! PR fortran/39295 ! * interface.c (compare_type_rank_if): Return 1 if the symbols ! are the same and deal with external procedures where one is ! identified to be a function or subroutine by usage but the ! other is not. ! 2009-02-26 Paul Thomas ! PR fortran/39292 ! * trans-array.c (gfc_conv_array_initializer): Convert all ! expressions rather than ICEing. ! 2009-02-21 Thomas Koenig ! PR fortran/38914 ! * array.c (ref_dimen_size): Rename to gfc_ref_dimen_size, ! make global. Change function name in error messages. ! (ref_size): Change ref_dimen_size to gfc_ref_dimen_size. ! (gfc_array_ref_shape): Likewise. ! * gfortran.h: Add prototype for gfc_ref_dimen_size. ! * simplify.c (simplify_bound_dim): Add ref argument. ! If the reference isn't a full array, return one for ! the lower bound and the extent for the upper bound. ! (simplify_bound): For array sections, take as from the ! argument. Add reference to all to simplify_bound_dim. ! 2009-02-19 Daniel Franke ! * scanner.c (load_line): At end of line, skip '\r' without setting ! the truncation flag. ! 2009-02-18 Daniel Kraft ! * gfortran.texi: New chapter about compiler characteristics. ! (Compiler Characteristics): Document KIND type parameters here. ! 2009-02-18 Tobias Burnus ! * intrinsic.texi (MALLOC): Make example more portable. ! 2009-02-13 Mikael Morin ! PR fortran/38259 ! * module.c (gfc_dump_module,gfc_use_module): Add module ! version number. ! 2009-02-13 Paul Thomas ! PR fortran/36703 ! PR fortran/36528 ! * trans-expr.c (gfc_conv_function_val): Stabilize Cray-pointer ! function references to ensure that a valid expression is used. ! (gfc_conv_function_call): Pass Cray pointers to procedures. ! 2009-02-03 Jakub Jelinek * gfortranspec.c (lang_specific_driver): Update copyright notice dates. ! 2009-01-28 Paul Thomas ! PR fortran/38852 ! PR fortran/39006 ! * trans-intrinsic.c (gfc_conv_intrinsic_bound): Use the array ! descriptor ubound for UBOUND, when the array lbound == 1. ! 2009-01-27 Daniel Kraft ! PR fortran/38883 ! * trans-stmt.c (gfc_conv_elemental_dependencies): Create temporary ! for the real type needed to make it work for subcomponent-references. ! 2009-01-21 Daniel Kraft ! * trans-stmt.c (gfc_conv_elemental_dependencies): Cleaned up comment. ! 2009-01-20 Paul Thomas ! PR fortran/38907 ! * resolve.c (check_host_association): Remove the matching to ! correct an incorrect host association and use manipulation of ! the expression instead. ! 2009-01-20 Tobias Burnus ! * invoke.texi (RANGE): RANGE also takes INTEGER arguments. ! 2009-01-19 Mikael Morin ! PR fortran/38859 ! * simplify.c (simplify_bound): Don't use array specification ! if variable or component has subsequent references. ! 2009-01-17 Paul Thomas ! PR fortran/38657 ! * module.c (write_common_0): Add argument 'this_module' and ! check that non-use associated common blocks are written first. ! (write_common): Call write_common_0 twice, once with true and ! then with false. ! 2009-01-17 Paul Thomas ! PR fortran/34955 ! * trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Has ! been absorbed into gfc_conv_intrinsic_transfer. All ! references to it in trans-intrinsic.c have been changed ! accordingly. PR fixed by using a temporary for scalar ! character transfer, when the source is shorter than the ! destination. ! 2009-01-17 Paul Thomas ! PR fortran/38657 ! * module.c (write_common_0): Revert patch of 2009-01-05. ! 2009-01-16 Janus Weil ! PR fortran/38152 ! * expr.c (gfc_check_pointer_assign): Allow use-associated procedure ! pointers as lvalue. ! * trans-decl.c (get_proc_pointer_decl,gfc_create_module_variable): ! Enable procedure pointers as module variables. ! 2009-01-14 Steven G. Kargl ! * ChangeLog-2007: Clean out svn merge droppings. ! 2009-01-10 Paul Thomas ! PR fortran/38763 ! * target-memory.c (encode_derived): Encode NULL. ! 2009-01-10 Paul Thomas ! PR fortran/38765 ! * resolve.c (check_host_association): Use the symtree name to ! search for a potential contained procedure, since this is the ! name by which it would be referenced. ! 2009-01-06 Thomas Koenig ! PR fortran/38220 ! * interface.c (gfc_procedure_use): Don't warn about functions ! from ISO_C_BINDING. ! * symbol.c (generate_isocbinding_symbol): Mark c_loc and ! c_funloc as pure. ! 2009-01-05 Paul Thomas ! PR fortran/38657 ! * module.c (write_common_0): Use the name of the symtree rather ! than the common block, to determine if the common has been ! written. ! 2009-01-05 Daniel Franke ! PR fortran/37159 ! * check.c (gfc_check_random_seed): Added size check for GET ! dummy argument, reworded error messages to follow common pattern. ! 2009-01-05 Thomas Koenig ! PR fortran/38672 ! * trans-types.c (gfc_get_derived_type): Check for the ! presence of derived->ns->proc_name before ! accessing derived->ns->proc_name->attr.flavor . ! * resolve.c (resolve_symbol): Likewise. ! 2009-01-05 Paul Thomas ! PR fortran/38665 ! * gfortran.h : Add bit to gfc_expr 'user_operator' ! * interface.c (gfc_extend_expr): Set the above if the operator ! is substituted by a function. ! * resolve.c (check_host_association): Return if above is set. ! 2009-01-04 Mikael Morin ! PR fortran/35681 ! * ChangeLog-2008: Fix function name. ! PR fortran/38487 ! * dependency.c (gfc_check_argument_var_dependency): ! Move the check for pointerness inside the if block ! so that it doesn't affect the return value. ! PR fortran/38669 ! * trans-stmt.c (gfc_trans_call): ! Add the dependency code after the loop bounds calculation one. ! 2009-01-04 Daniel Franke ! * intrinsic.c (do_simplify): Removed already implemented TODO. ! 2009-01-04 Daniel Franke ! PR fortran/38718 ! * simplify.c (gfc_simplify_merge): New. ! * intrinsic.h (gfc_simplify_merge): New prototype. ! * intrinsic.c (add_functions): Added simplification for MERGE. ! 2009-01-04 Mikael Morin ! PR fortran/38536 ! * gfortran.h (gfc_is_data_pointer): Added prototype ! * resolve.c (gfc_iso_c_func_interface): ! Use gfc_is_data_pointer to test for pointer attribute. ! * dependency.c (gfc_is_data_pointer): ! Support pointer-returning functions. ! 2009-01-03 Daniel Franke ! * symbol.c (save_symbol): Don't SAVE function results. ! 2009-01-03 Paul Thomas ! PR fortran/38594 ! * resolve.c (resolve_call): When searching for proper host ! association, use symtree rather than symbol. For everything ! except generic subroutines, substitute the symtree in the call ! rather than the symbol. diff -Nrcpad gcc-4.3.3/gcc/fortran/ChangeLog-2004 gcc-4.4.0/gcc/fortran/ChangeLog-2004 *** gcc-4.3.3/gcc/fortran/ChangeLog-2004 Sun Jan 1 17:04:47 2006 --- gcc-4.4.0/gcc/fortran/ChangeLog-2004 Fri Sep 5 11:07:45 2008 *************** *** 2169,2175 **** * symbol.c (gfc_add_common): Disable checks to work around other more fundamental inadequacies. ! 2004-05-22 Tobias Schlter * trans-decl.c (gfc_get_extern_function_decl): Set DECL_IS_PURE only for functions. --- 2169,2175 ---- * symbol.c (gfc_add_common): Disable checks to work around other more fundamental inadequacies. ! 2004-05-22 Tobias Schlüter * trans-decl.c (gfc_get_extern_function_decl): Set DECL_IS_PURE only for functions. *************** *** 2377,2383 **** * decl.c (variable_decl): Always apply default initializer. ! 2004-05-08 Tobias Schlter PR fortran/15206 * trans-intrinsic.c (gfc_conv_intrinsic_rrspacing): Fixed to --- 2377,2383 ---- * decl.c (variable_decl): Always apply default initializer. ! 2004-05-08 Tobias Schlüter PR fortran/15206 * trans-intrinsic.c (gfc_conv_intrinsic_rrspacing): Fixed to *************** *** 2451,2457 **** Remove "set DEVELOPMENT". (Compiling GFORTRAN): Remove. ! 2004-05-09 Tobias Schlter * array.c (match_subscript, match_array_ref): Add comments explaining argument 'init'. --- 2451,2457 ---- Remove "set DEVELOPMENT". (Compiling GFORTRAN): Remove. ! 2004-05-09 Tobias Schlüter * array.c (match_subscript, match_array_ref): Add comments explaining argument 'init'. *************** *** 2461,2480 **** * primary.c (match_digits, match_integer_constant): Add comment explaining signflag. ! 2004-05-01 Tobias Schlter PR fortran/13940 * primary.c: Include system.h and flags.h, needed for pedantic. (match_boz_constant): Allow "x" for hexadecimal constants, warn if pedantic is set. ! 2004-05-01 Tobias Schlter PR fortran/13940 * match.c (match_data_constant): Handle case where gfc_find_symbol sets sym to NULL ! 2004-04-28 Tobias Schlter * Make-lang.in (f95-lang.o, trans-intrinsic.o): Add missing dependency on mathbuiltins.def --- 2461,2480 ---- * primary.c (match_digits, match_integer_constant): Add comment explaining signflag. ! 2004-05-01 Tobias Schlüter PR fortran/13940 * primary.c: Include system.h and flags.h, needed for pedantic. (match_boz_constant): Allow "x" for hexadecimal constants, warn if pedantic is set. ! 2004-05-01 Tobias Schlüter PR fortran/13940 * match.c (match_data_constant): Handle case where gfc_find_symbol sets sym to NULL ! 2004-04-28 Tobias Schlüter * Make-lang.in (f95-lang.o, trans-intrinsic.o): Add missing dependency on mathbuiltins.def *************** *** 2488,2494 **** * gfortranspec.c: Do not include multilib.h. ! 2004-04-24 Tobias Schlter * trans-intrinsic.c: Fix comment, this is not trans-expr.c. Add 2004 to copyright years. --- 2488,2494 ---- * gfortranspec.c: Do not include multilib.h. ! 2004-04-24 Tobias Schlüter * trans-intrinsic.c: Fix comment, this is not trans-expr.c. Add 2004 to copyright years. diff -Nrcpad gcc-4.3.3/gcc/fortran/ChangeLog-2005 gcc-4.4.0/gcc/fortran/ChangeLog-2005 *** gcc-4.3.3/gcc/fortran/ChangeLog-2005 Sun Jan 1 17:04:47 2006 --- gcc-4.4.0/gcc/fortran/ChangeLog-2005 Fri Sep 5 11:07:45 2008 *************** *** 21,27 **** PR fortran/25587 * trans-io.c (gfc_build_st_parameter): Correct off by one error. ! 2005-12-28 Rafael vila de Espndola * Make-lang.in: Remove distdir from comment. --- 21,27 ---- PR fortran/25587 * trans-io.c (gfc_build_st_parameter): Correct off by one error. ! 2005-12-28 Rafael Ávila de Espíndola * Make-lang.in: Remove distdir from comment. *************** *** 399,409 **** as actual arguments to ASSOCIATED. Moved a misplaced comment. ! 2005-12-07 Rafael vila de Espndola * Make-lang.in (fortran.all.build, fortran.install-normal): Remove. ! 2005-12-07 Rafael vila de Espndola * Make-lang.in: Remove all dependencies on s-gtype, except for gt-fortran-trans.h. --- 399,409 ---- as actual arguments to ASSOCIATED. Moved a misplaced comment. ! 2005-12-07 Rafael Ávila de Espíndola * Make-lang.in (fortran.all.build, fortran.install-normal): Remove. ! 2005-12-07 Rafael Ávila de Espíndola * Make-lang.in: Remove all dependencies on s-gtype, except for gt-fortran-trans.h. diff -Nrcpad gcc-4.3.3/gcc/fortran/ChangeLog-2006 gcc-4.4.0/gcc/fortran/ChangeLog-2006 *** gcc-4.3.3/gcc/fortran/ChangeLog-2006 Mon Jan 1 19:22:09 2007 --- gcc-4.4.0/gcc/fortran/ChangeLog-2006 Fri Sep 5 11:07:45 2008 *************** *** 112,118 **** the nullifying of intent(out) arguments rather than the backend declaration. ! 2006-12-20 Tobias Schlter PR fortran/25392 * trans-stmt.c (gfc_trans_return): Fix comment formatting. --- 112,118 ---- the nullifying of intent(out) arguments rather than the backend declaration. ! 2006-12-20 Tobias Schlüter PR fortran/25392 * trans-stmt.c (gfc_trans_return): Fix comment formatting. *************** *** 215,221 **** function declarations to match the library changes. Mark allocation functions with DECL_IS_MALLOC. ! 2006-12-12 Tobias Schlter * trans-expr.c (gfc_conv_substring): Check for empty substring. --- 215,221 ---- function declarations to match the library changes. Mark allocation functions with DECL_IS_MALLOC. ! 2006-12-12 Tobias Schlüter * trans-expr.c (gfc_conv_substring): Check for empty substring. *************** *** 669,675 **** * trans-expr.c (gfc_conv_expr_reference): Set TREE_STATIC on the new CONST_DECL. ! 2006-11-11 Tobias Schlter * array.c: Add 2006 to copyright years. * data.c: Same. --- 669,675 ---- * trans-expr.c (gfc_conv_expr_reference): Set TREE_STATIC on the new CONST_DECL. ! 2006-11-11 Tobias Schlüter * array.c: Add 2006 to copyright years. * data.c: Same. *************** *** 969,975 **** * expr.c (simplify_parameter_variable): Keep rank of original expression. ! 2006-10-23 Rafael Avila de Espindola * Make-lang.in (f951$(exeext)): Depend on and link with attribs.o. * trans.h (builtin_function): Rename to gfc_builtin_function. --- 969,975 ---- * expr.c (simplify_parameter_variable): Keep rank of original expression. ! 2006-10-23 Rafael Ávila de Espíndola * Make-lang.in (f951$(exeext)): Depend on and link with attribs.o. * trans.h (builtin_function): Rename to gfc_builtin_function. *************** *** 1566,1572 **** PR fortran/29097 * scanner.c (include_line): Handle conditional include. ! 2006-09-25 Tobias Schluter PR fortran/21203 * error.c (show_loci): No need to risk an ICE to output a --- 1566,1572 ---- PR fortran/29097 * scanner.c (include_line): Handle conditional include. ! 2006-09-25 Tobias Schlüter PR fortran/21203 * error.c (show_loci): No need to risk an ICE to output a *************** *** 1599,1605 **** * iresolve.c (resolve_spread): Build shape for result if the source shape is available and dim and ncopies are constants. ! 2006-09-18 Tobias Schlter PR fortran/28817 PR fortran/21918 --- 1599,1605 ---- * 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 *************** *** 2121,2127 **** * intrinsic.texi: Document new intrinsics. ! 2006-07-01 Tobias Schlter PR fortran/19259 * parse.c (next_free): Error out on line starting with semicolon. --- 2121,2127 ---- * intrinsic.texi: Document new intrinsics. ! 2006-07-01 Tobias Schlüter PR fortran/19259 * parse.c (next_free): Error out on line starting with semicolon. *************** *** 2728,2734 **** * parse.c (next_statement): Add check to avoid an ICE when gfc_current_locus.lb is not set. ! 2006-05-07 Tobias Schlter PR fortran/27457 * match.c (match_case_eos): Error out on garbage following --- 2728,2734 ---- * parse.c (next_statement): Add check to avoid an ICE when gfc_current_locus.lb is not set. ! 2006-05-07 Tobias Schlüter PR fortran/27457 * match.c (match_case_eos): Error out on garbage following *************** *** 2749,2755 **** -fall-intrinsics is used. (gfc_handle_option): Permit -Wno-nonstd-intrinsics. ! 2006-05-04 Tobias Schlter * simplify.c (ascii_table): Fix wrong entry. --- 2749,2755 ---- -fall-intrinsics is used. (gfc_handle_option): Permit -Wno-nonstd-intrinsics. ! 2006-05-04 Tobias Schlüter * simplify.c (ascii_table): Fix wrong entry. *************** *** 3357,3363 **** * module.c (read_module): Remove redundant code lines. ! 2006-02-20 Rafael vila de Espndola * Make-lang.in (FORTRAN): Remove (.PHONY): Remove F95 and f95. Add fortran --- 3357,3363 ---- * module.c (read_module): Remove redundant code lines. ! 2006-02-20 Rafael Ávila de Espíndola * Make-lang.in (FORTRAN): Remove (.PHONY): Remove F95 and f95. Add fortran *************** *** 3456,3462 **** PR fortran/26054 * options.c: Do not warn for Fortran 2003 features by default. ! 2006-02-15 Tobias Schlter * check.c: Update copyright years. --- 3456,3462 ---- PR fortran/26054 * options.c: Do not warn for Fortran 2003 features by default. ! 2006-02-15 Tobias Schlüter * check.c: Update copyright years. *************** *** 3479,3485 **** to check dim argument. (check_reduction): Likewise. ! 2006-02-14 Tobias Schlter PR fortran/26277 * io.c (match_ltag): Mark label as referenced. --- 3479,3485 ---- to check dim argument. (check_reduction): Likewise. ! 2006-02-14 Tobias Schlüter PR fortran/26277 * io.c (match_ltag): Mark label as referenced. *************** *** 3930,3943 **** are set. ! 2006-02-10 Tobias Schlter PR fortran/14771 * arith.c (eval_intrinsic): Accept INTRINSIC_PARENTHESES. * expr.c (check_intrinsic_op): Likewise. * module.c (mio_expr): Likewise. ! 2006-02-09 Tobias Schlter * dump-parse-tree.c: Update copyright years. * matchexp.c: Likewise. --- 3930,3943 ---- are set. ! 2006-02-10 Tobias Schlüter PR fortran/14771 * arith.c (eval_intrinsic): Accept INTRINSIC_PARENTHESES. * expr.c (check_intrinsic_op): Likewise. * module.c (mio_expr): Likewise. ! 2006-02-09 Tobias Schlüter * dump-parse-tree.c: Update copyright years. * matchexp.c: Likewise. *************** *** 4319,4325 **** is_aliased_array and convert it to a temporary and back again using gfc_conv_aliased_arg. ! 2006-01-19 Tobias Schlter * gfortranspec.c: Update copyright years. * trans.c: Likewise. --- 4319,4325 ---- is_aliased_array and convert it to a temporary and back again using gfc_conv_aliased_arg. ! 2006-01-19 Tobias Schlüter * gfortranspec.c: Update copyright years. * trans.c: Likewise. *************** *** 4330,4336 **** * trans-stmt.h: Likewise. * trans-types.c: Likewise. ! 2006-01-18 Tobias Schlter PR fortran/18540 PR fortran/18937 --- 4330,4336 ---- * trans-stmt.h: Likewise. * trans-types.c: Likewise. ! 2006-01-18 Tobias Schlüter PR fortran/18540 PR fortran/18937 *************** *** 4375,4381 **** argument checking. Replace strcmp's with comparisons with generic codes. ! 2006-01-16 Rafael vila de Espndola * gfortranspec.c (lang_specific_spec_functions): Remove. --- 4375,4381 ---- argument checking. Replace strcmp's with comparisons with generic codes. ! 2006-01-16 Rafael Ávila de Espíndola * gfortranspec.c (lang_specific_spec_functions): Remove. *************** *** 4412,4418 **** * trans.c (gfc_add_expr_to_block): Do not fold tcc_statement nodes. ! 2006-01-11 Tobias Schlter * parse.c (next_fixed): Remove superfluous string concatenation. --- 4412,4418 ---- * trans.c (gfc_add_expr_to_block): Do not fold tcc_statement nodes. ! 2006-01-11 Tobias Schlüter * parse.c (next_fixed): Remove superfluous string concatenation. diff -Nrcpad gcc-4.3.3/gcc/fortran/ChangeLog-2007 gcc-4.4.0/gcc/fortran/ChangeLog-2007 *** gcc-4.3.3/gcc/fortran/ChangeLog-2007 Wed Jan 2 17:54:50 2008 --- gcc-4.4.0/gcc/fortran/ChangeLog-2007 Wed Jan 14 21:22:53 2009 *************** *** 87,93 **** * module.c (read_module): Check sym->module is there before using it in a string comparison. - >>>>>>> .r131138 2007-12-20 Tobias Burnus PR fortran/34482 --- 87,92 ---- *************** *** 870,876 **** (gfc_dep_resolver): Correct the logic for substrings so that overlapping arrays are handled correctly. ! 2007-10-28 Tobias Schlter PR fortran/32147 * module.c (write_symbol): Fix whitespace. --- 869,875 ---- (gfc_dep_resolver): Correct the logic for substrings so that overlapping arrays are handled correctly. ! 2007-10-28 Tobias Schlüter PR fortran/32147 * module.c (write_symbol): Fix whitespace. *************** *** 985,991 **** namespaces and start search for symbol in current namespace. 2007-10-18 Paul Thomas ! Dominique d'Humieres PR fortran/33733 * simplify.c (gfc_simplify_transfer): Return null if the source --- 984,990 ---- namespaces and start search for symbol in current namespace. 2007-10-18 Paul Thomas ! Dominique d'Humières PR fortran/33733 * simplify.c (gfc_simplify_transfer): Return null if the source *************** *** 1028,1034 **** * resolve.c (check_dimension): Fix dimension-type switch; improve error message. ! 2007-10-13 Tobias Schlter Paul Thomas PR fortran/33254 --- 1027,1033 ---- * resolve.c (check_dimension): Fix dimension-type switch; improve error message. ! 2007-10-13 Tobias Schlüter Paul Thomas PR fortran/33254 *************** *** 1055,1061 **** PR fortran/33636 * expr.c (find_array_section): Check for constructor constantness. ! 2007-10-08 Tobias Schlter PR fortran/33689 * resolve.c (gfc_resolve_expr): Fix indentation. --- 1054,1060 ---- PR fortran/33636 * expr.c (find_array_section): Check for constructor constantness. ! 2007-10-08 Tobias Schlüter PR fortran/33689 * resolve.c (gfc_resolve_expr): Fix indentation. *************** *** 1069,1075 **** * mathbuiltins.def (GAMMA): Change function name to "tgamma" instad of "gamma". ! 2007-10-07 Tobias Schlter PR fortran/20851 * expr.c (check_inquiry): Typo fix in error message. --- 1068,1074 ---- * mathbuiltins.def (GAMMA): Change function name to "tgamma" instad of "gamma". ! 2007-10-07 Tobias Schlüter PR fortran/20851 * expr.c (check_inquiry): Typo fix in error message. *************** *** 1085,1095 **** * simplify.c (range_check): Return gfc_bad_expr if incoming expression is NULL. ! 2007-10-06 Tobias Schlter * simplify.c (gfc_simplify_size): Fix typo. ! 2007-10-06 Tobias Schlter PR fortran/25076 * resolve.c (gfc_find_forall_index): Move towards top, --- 1084,1094 ---- * simplify.c (range_check): Return gfc_bad_expr if incoming expression is NULL. ! 2007-10-06 Tobias Schlüter * simplify.c (gfc_simplify_size): Fix typo. ! 2007-10-06 Tobias Schlüter PR fortran/25076 * resolve.c (gfc_find_forall_index): Move towards top, *************** *** 1148,1154 **** * gfortran.h (gfc_linebuf): Add dbg_emitted field. (gfc_define_undef_line): New prototype. ! 2007-10-04 Tobias Schlter PR fortran/33626 * resolve.c (resolve_operator): Always copy the type for --- 1147,1153 ---- * gfortran.h (gfc_linebuf): Add dbg_emitted field. (gfc_define_undef_line): New prototype. ! 2007-10-04 Tobias Schlüter PR fortran/33626 * resolve.c (resolve_operator): Always copy the type for *************** *** 1166,1172 **** * trans-decl.c (build_function_decl): Set "externally_visible" attribute on the MAIN program decl. ! 2007-10-03 Tobias Schlter PR fortran/33198 * resolve.c (has_default_initializer): Move to top. Make bool. --- 1165,1171 ---- * trans-decl.c (build_function_decl): Set "externally_visible" attribute on the MAIN program decl. ! 2007-10-03 Tobias Schlüter PR fortran/33198 * resolve.c (has_default_initializer): Move to top. Make bool. *************** *** 1239,1245 **** * module.c (mio_expr): Avoid -Wcast-qual warning. ! 2007-09-27 Tobias Schlter * arith.c (reduce_binary_aa): Fix capitalization. * check.c (gfc_check_dot_product): Likewise. --- 1238,1244 ---- * module.c (mio_expr): Avoid -Wcast-qual warning. ! 2007-09-27 Tobias Schlüter * arith.c (reduce_binary_aa): Fix capitalization. * check.c (gfc_check_dot_product): Likewise. *************** *** 1264,1270 **** PR fortran/30780 * invoke.texi: Add note to -ffpe-trap option. Fix typos. ! 2007-09-23 Tobias Schlter PR fortran/33269 * io.c (check_format_string): Move NULL and constant checks into --- 1263,1269 ---- PR fortran/30780 * invoke.texi: Add note to -ffpe-trap option. Fix typos. ! 2007-09-23 Tobias Schlüter PR fortran/33269 * io.c (check_format_string): Move NULL and constant checks into *************** *** 1373,1379 **** reduce_binary_aa): Call ourselves recursively if an element of the constructor is itself a constant array. ! 2007-09-20 Tobias Schlter * io.c (resolve_tag_format): New function using code split out and simplified from ... --- 1372,1378 ---- reduce_binary_aa): Call ourselves recursively if an element of the constructor is itself a constant array. ! 2007-09-20 Tobias Schlüter * io.c (resolve_tag_format): New function using code split out and simplified from ... *************** *** 1663,1669 **** * match.c (gfc_match_strings): Delete unused function. * match.h (gfc_match_strings): Delete prototype. ! 2007-09-02 Tobias Schluter * dump-parse-tree.c (show_char_const): New function. (gfc_show_expr): Use it. --- 1662,1668 ---- * match.c (gfc_match_strings): Delete unused function. * match.h (gfc_match_strings): Delete prototype. ! 2007-09-02 Tobias Schlüter * dump-parse-tree.c (show_char_const): New function. (gfc_show_expr): Use it. *************** *** 1879,1885 **** runtime error checking. 2007-08-22 Roger Sayle ! Tobias Schlter * match.c (intrinsic_operators): Delete. (gfc_match_intrinsic_op): Rewrite matcher to avoid calling --- 1878,1884 ---- runtime error checking. 2007-08-22 Roger Sayle ! Tobias Schlüter * match.c (intrinsic_operators): Delete. (gfc_match_intrinsic_op): Rewrite matcher to avoid calling *************** *** 2897,2903 **** dummy arguments, tell middle-end not to emit additional warnings. 2007-07-08 Daniel Franke ! Tobias Schlter PR fortran/17711 * gfortran.h (gfc_intrinsic_op): Added INTRINSIC_EQ_OS, --- 2896,2902 ---- dummy arguments, tell middle-end not to emit additional warnings. 2007-07-08 Daniel Franke ! Tobias Schlüter PR fortran/17711 * gfortran.h (gfc_intrinsic_op): Added INTRINSIC_EQ_OS, *************** *** 3430,3436 **** the total offset to the field. * target-memory.h : Add prototype for gfc_merge_initializers. ! 2007-06-11 Rafael Avila de Espindola * trans-types.c (gfc_signed_type): Remove. * trans-types.h (gfc_signed_type): Remove. --- 3429,3435 ---- the total offset to the field. * target-memory.h : Add prototype for gfc_merge_initializers. ! 2007-06-11 Rafael Ávila de Espíndola * trans-types.c (gfc_signed_type): Remove. * trans-types.h (gfc_signed_type): Remove. *************** *** 3839,3845 **** * trans-expr.c (gfc_conv_substring): Evaluate substring bounds only once. ! 2007-05-14 Rafael Avila de Espindola * f95-lang.c (LANG_HOOKS_UNSIGNED_TYPE): Remove. * trans-intrinsic.c (gfc_conv_intrinsic_ishft): Use unsigned_type_for --- 3838,3844 ---- * trans-expr.c (gfc_conv_substring): Evaluate substring bounds only once. ! 2007-05-14 Rafael Ávila de Espíndola * f95-lang.c (LANG_HOOKS_UNSIGNED_TYPE): Remove. * trans-intrinsic.c (gfc_conv_intrinsic_ishft): Use unsigned_type_for *************** *** 4392,4398 **** * gfortran.texi: Add a section for the %VAL, %REF and %LOC extensions. ! 2007-03-30 Rafael Avila de Espindola * trans-types.c (gfc_signed_or_unsigned_type): Remove. (gfc_unsigned_type): Use get_signed_or_unsigned_type instead of --- 4391,4397 ---- * gfortran.texi: Add a section for the %VAL, %REF and %LOC extensions. ! 2007-03-30 Rafael Ávila de Espíndola * trans-types.c (gfc_signed_or_unsigned_type): Remove. (gfc_unsigned_type): Use get_signed_or_unsigned_type instead of diff -Nrcpad gcc-4.3.3/gcc/fortran/ChangeLog-2008 gcc-4.4.0/gcc/fortran/ChangeLog-2008 *** gcc-4.3.3/gcc/fortran/ChangeLog-2008 Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/fortran/ChangeLog-2008 Sun Jan 4 19:12:16 2009 *************** *** 0 **** --- 1,4135 ---- + 2008-12-31 Daniel Franke + + * check.c (dim_rank_check): Fixed checking of dimension argument + if array is of type EXPR_ARRAY. + + 2008-12-22 Paul Thomas + + PR fortran/38602 + * trans-decl.c (init_intent_out_dt): Allow for optional args. + + 2008-12-21 Jerry DeLisle + + PR fortran/38398 + * io.c: Add error checks for g0 formatting and provide adjustment of + error loci for improved error messages. + + 2008-12-21 Arjen Markus + Daniel Kraft + + PR fortran/37605 + * gfortran.texi: Fixed some typos and some minor style improvements. + * intrinsic.texi: Some clarifications and typo-fixes. + * invoke.texi: Better documenation of the behaviour of the + -fdefault-*-8 options and some other fixes. + + 2008-12-18 Daniel Kraft + + PR fortran/31822 + * gfortran.h (gfc_check_same_strlen): Made public. + * trans.h (gfc_trans_same_strlen_check): Made public. + * check.c (gfc_check_same_strlen): Made public and adapted error + message output to be useful not only for intrinsics. + (gfc_check_merge): Adapt to gfc_check_same_strlen change. + * expr.c (gfc_check_pointer_assign): Use gfc_check_same_strlen for + string length compile-time check. + * trans-expr.c (gfc_trans_pointer_assignment): Add runtime-check for + equal string lengths using gfc_trans_same_strlen_check. + * trans-intrinsic.c (gfc_trans_same_strlen_check): Renamed and made + public from conv_same_strlen_check. + (gfc_conv_intrinsic_merge): Adapted accordingly. + + 2008-12-17 Daniel Kraft + + PR fortran/38137 + * trans-intrinsic.c (conv_same_strlen_check): New method. + (gfc_conv_intrinsic_merge): Call it here to actually do the check. + + 2008-12-15 Mikael Morin + + PR fortran/38487 + * dependency.c (gfc_is_data_pointer): New function. + (gfc_check_argument_var_dependency): Disable the warning + in the pointer case. + (gfc_check_dependency): Use gfc_is_data_pointer. + + 2008-12-15 Mikael Morin + + PR fortran/38113 + * error.c (show_locus): Start counting columns at 0. + * primary.c (match_actual_arg): Eat spaces + before copying the current locus. + (match_variable): Copy the locus before matching. + + 2008-12-14 Paul Thomas + + PR fortran/35937 + * trans-expr.c (gfc_finish_interface_mapping): Fold convert the + character length to gfc_charlen_type_node. + + 2008-12-12 Daniel Franke + + PR fortran/36355 + * check.c (gfc_check_matmul): Fixed error message for invalid + types to correctly identify the offending argument, added check + for mismatching types. + + 2008-12-11 Richard Guenther + + * Make-lang.in (install-finclude-dir): Use correct mode argument + for mkinstalldirs. + + 2008-12-09 Daniel Franke + + PR fortran/36376 + PR fortran/37468 + * lang-specs.h: Pass on -i* options to f951 to (probably) report + them as unknown. Duplicate gcc.c (cpp_options), but omit + -fpch-preprocess on -save-temps. + + 2008-12-09 Daniel Franke + + PR fortran/36457 + * lang.opt: Added option idirafter. + * cpp.h (gfc_cpp_add_include_path_after): New prototype. + * cpp.c (gfc_cpp_handle_option): Recognize and handle OPT_dirafter. + (gfc_cpp_add_include_path_after): New, adds user-defined search path + after any other paths. + * invoke.texi (idirafter): New. + (no-range-check): Fixed entry in option-index. + + 2008-12-09 Mikael Morin + + PR fortran/37469 + * expr.c (find_array_element): Simplify array bounds. + Assert that both bounds are constant expressions. + + 2008-12-09 Mikael Morin + + PR fortran/35983 + * trans-expr.c (gfc_trans_subcomponent_assign): + Add se's pre and post blocks to current block. + (gfc_trans_structure_assign): Remove specific handling + of C_NULL_PTR and C_NULL_FUNPTR. + + 2008-12-06 Jerry DeLisle + + PR fortran/38425 + * io.c (check_io_constraints): Check constraints on REC=, POS=, and + internal unit with POS=. Fix punctuation on a few error messages. + + 2008-12-06 Janus Weil + + PR fortran/38415 + * expr.c (gfc_check_pointer_assign): Added a check for abstract + interfaces in procedure pointer assignments, removed check involving + gfc_compare_interfaces until PR38290 is fixed completely. + + 2008-12-05 Jerry DeLisle + + PR fortran/38291 + * io.c (match_dt_element): Use dt->pos in matcher. + (gfc_free_dt): Free dt->pos after use. + (gfc_resolve_dt): Use dt->pos in resolution of stream position tag. + + 2008-12-05 Sebastian Pop + + PR bootstrap/38262 + * Make-lang.in (f951): Add BACKENDLIBS, remove GMPLIBS. + + 2008-12-02 Jakub Jelinek + Diego Novillo + + * Make-lang.in (install-finclude-dir): Use mkinstalldirs + and don't remove the finclude directory beforehand. + + 2008-12-02 Janus Weil + + PR fortran/36704 + PR fortran/38290 + * decl.c (match_result): Result may be a standard variable or a + procedure pointer. + * expr.c (gfc_check_pointer_assign): Additional checks for procedure + pointer assignments. + * primary.c (gfc_match_rvalue): Bugfix for procedure pointer + assignments. + * resolve.c (resolve_function): Check for attr.subroutine. + * symbol.c (check_conflict): Addtional checks for RESULT statements. + * trans-types.c (gfc_sym_type,gfc_get_function_type): Support procedure + pointers as function result. + + 2008-12-01 Mikael Morin + + PR fortran/38252 + * parse.c (parse_spec): Skip statement order check in case + of a CONTAINS statement. + + 2008-11-30 Daniel Kraft + + PR fortran/37779 + * gfortran.h (struct gfc_entry_list): Fixed typo in comment. + * resolve.c (is_illegal_recursion): New method. + (resolve_procedure_expression): Use new is_illegal_recursion instead of + direct check and handle function symbols correctly. + (resolve_actual_arglist): Removed useless recursion check. + (resolve_function): Use is_illegal_recursion instead of direct check. + (resolve_call): Ditto. + + 2008-11-29 Eric Botcazou + + * trans-array.c (gfc_conv_array_parameter): Guard union access. + + 2008-11-29 Janus Weil + Mikael Morin + + PR fortran/38289 + PR fortran/38290 + * decl.c (match_procedure_decl): Handle whitespaces. + * resolve.c (resolve_specific_s0): Bugfix in check for intrinsic + interface. + + 2008-11-25 H.J. Lu + + * module.c (gfc_dump_module): Report error on unlink only if + errno != ENOENT. + + 2008-11-25 Mikael Morin + + PR fortran/36463 + * expr.c (replace_symbol): Don't replace the symtree + if the expresion is an intrinsic function. Don't create + non-existent symtrees. Use symbol's name instead of symtree's, + different in case of module procedure dummy arguments. + + 2008-11-25 Jan Kratochvil + + PR fortran/38248 + * module.c (gfc_dump_module): Check rename/unlink syscalls errors. + + 2008-11-25 Eric Botcazou + + PR fortran/37319 + * parse.c (match_deferred_characteristics): Make sure 'name' is + initialized before reading it. + + 2008-11-24 Jerry DeLisle + + PR fortran/37803 + * arith.c (gfc_check_real_range): Add mpfr_check_range. + * simplify.c (gfc_simplify_nearest): Add mpfr_check_range. + + 2008-11-24 Mikael Morin + + PR fortran/38184 + * simplify.c (is_constant_array_expr): Return true instead of false + if the array constructor is empty. + + 2008-11-24 Daniel Kraft + + PR fortran/37779 + * resolve.c (resolve_procedure_expression): New method. + (resolve_variable): Call it. + (resolve_actual_arglist): Call gfc_resolve_expr for procedure arguments. + + 2008-11-24 Paul Thomas + + PR fortran/34820 + * trans-expr.c (gfc_conv_function_call): Remove all code to + deallocate intent out derived types with allocatable + components. + (gfc_trans_assignment_1): An assignment from a scalar to an + array of derived types with allocatable components, requires + a deep copy to each array element and deallocation of the + converted rhs expression afterwards. + * trans-array.c : Minor whitespace. + * trans-decl.c (init_intent_out_dt): Add code to deallocate + allocatable components of derived types with intent out. + (generate_local_decl): If these types are unused, set them + referenced anyway but allow the uninitialized warning. + + PR fortran/34143 + * trans-expr.c (gfc_trans_subcomponent_assign): If a conversion + expression has a null data pointer argument, nullify the + allocatable component. + + PR fortran/32795 + * trans-expr.c (gfc_trans_subcomponent_assign): Only nullify + the data pointer if the source is not a variable. + + 2008-11-23 Paul Thomas + + PR fortran/37735 + * trans-array.c (structure_alloc_comps): Do not duplicate the + descriptor if this is a descriptorless array! + + 2008-11-12 Tobias Burnus + + PR fortran/38160 + * trans-types.c (gfc_validate_c_kind): Remove function. + * decl.c (gfc_match_kind_spec): Add C kind parameter check. + (verify_bind_c_derived_type): Remove gfc_validate_c_kind call. + (verify_c_interop_param): Update call. + * gfortran.h (verify_bind_c_derived_type): Update prototype. + (gfc_validate_c_kind): Remove. + * symbol.c (verify_bind_c_derived_type): Update verify_c_interop call. + * resolve.c (gfc_iso_c_func_interface): Ditto. + + 2008-11-22 Jakub Jelinek + + PR libfortran/37839 + * trans-io.c (gfc_build_io_library_fndecls): Decrease pad size back + to 16 pointers plus 32 integers. Don't use max integer kind + alignment, only gfc_intio_kind's alignment. + (gfc_trans_inquire): Only set flags2 if mask2 is non-zero. + * ioparm.def: Fix order, bitmasks and types of inquire round, sign + and pending fields. Move u in dt before id. + * io.c (gfc_free_inquire): Free decimal and size exprs. + (match_inquire_element): Match size instead of matching blank twice. + (gfc_resolve_inquire): Resolve size. + + 2008-11-20 Jakub Jelinek + + PR middle-end/29215 + * trans-array.c (trans_array_constructor_value, + gfc_build_constant_array_constructor): Fill in TREE_PURPOSE. + + * trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Use + gfc_index_one_node. + (gfc_conv_intrinsic_size): Use gfc_index_{zero,one}_node. + + PR fortran/38181 + * trans-intrinsic.c (gfc_conv_intrinsic_size): Inline 2 argument + size if the second argument is not optional and one argument size + for rank 1 arrays. + + 2008-11-19 Paul Thomas + + PR fortran/38171 + * module.c (load_equiv): Regression fix; check that equivalence + members come from the same module only. + + 2008-11-16 Mikael Morin + + PR fortran/35681 + * dependency.c (gfc_check_argument_var_dependency): Add + elemental check flag. Issue a warning if we find a dependency + but don't generate a temporary. Add the case of an elemental + function call as actual argument to an elemental procedure. + Add the case of an operator expression as actual argument + to an elemental procedure. + (gfc_check_argument_dependency): Add elemental check flag. + Update calls to gfc_check_argument_var_dependency. + (gfc_check_fncall_dependency): Add elemental check flag. + Update call to gfc_check_argument_dependency. + * trans-stmt.c (gfc_trans_call): Make call to + gfc_conv_elemental_dependencies unconditional, but with a flag + whether we should check dependencies between variables. + (gfc_conv_elemental_dependencies): Add elemental check flag. + Update call to gfc_check_fncall_dependency. + * trans-expr.c (gfc_trans_arrayfunc_assign): Update call to + gfc_check_fncall_dependency. + * resolve.c (find_noncopying_intrinsics): Update call to + gfc_check_fncall_dependency. + * dependency.h (enum gfc_dep_check): New enum. + (gfc_check_fncall_dependency): Update prototype. + + 2008-11-16 Mikael Morin + + PR fortran/37992 + * gfortran.h (gfc_namespace): Added member old_cl_list, + backup of cl_list. + (gfc_free_charlen): Added prototype. + * symbol.c (gfc_free_charlen): New function. + (gfc_free_namespace): Use gfc_free_charlen. + * parse.c (next_statement): Backup gfc_current_ns->cl_list. + (reject_statement): Restore gfc_current_ns->cl_list. + Free cl_list's elements before dropping them. + + 2008-11-16 Tobias Burnus + + PR fortran/38095 + * trans-expr.c (gfc_map_intrinsic_function): Fix pointer access. + + 2008-11-16 Paul Thomas + + PR fortran/38119 + * trans-array.c (gfc_trans_create_temp_array): Set the + loop->from to zero and the renormalisation of loop->to for all + dimensions. + + 2008-11-16 Paul Thomas + + PR fortran/37926 + * trans-expr.c (gfc_free_interface_mapping): Null sym->formal + (gfc_add_interface_mapping): Copy the pointer to the formal + arglist, rather than using copy_formal_args - fixes regression. + + 2008-11-15 Paul Thomas + + PR fortran/37926 + * trans-expr.c (gfc_add_interface_mapping): Transfer the formal + arglist and the always_explicit attribute if the dummy arg is a + procedure. + + 2008-11-14 Jerry DeLisle + + PR fortran/37988 + * io.c (enum format_token): For readability replace FMT_POS with FMT_T, + FMT_TL, and FMT_TR. (format_lex): Use new enumerators. (check_format): + Add check for missing positive integer. + + 2008-10-14 Paul Thomas + + PR fortran/38033 + * trans-array.c (gfc_trans_create_temp_array): Stabilize the + 'to' expression. + (gfc_conv_loop_setup): Use the end expression for the loop 'to' + if it is available. + + 2008-11-12 Jakub Jelinek + + PR target/35366 + PR fortran/33759 + * trans-const.c (gfc_conv_constant_to_tree): Warn when + converting an integer outside of LOGICAL's range to + LOGICAL. + * trans-intrinsic.c (gfc_conv_intrinsic_function, + gfc_conv_intrinsic_array_transfer, gfc_conv_intrinsic_transfer): + Use INTEGER_TYPE instead of BOOLEAN_TYPE for TRANSFER as + argument of another TRANSFER. + + 2008-11-12 Tobias Burnus + + PR fortran/38065 + * resolve.c (resolve_fntype): Fix private derived type checking. + + 2008-11-09 Paul Thomas + + PR fortran/37836 + * intrinsic.c (add_functions): Reference gfc_simplify._minval + and gfc_simplify_maxval. + * intrinsic.h : Add prototypes for gfc_simplify._minval and + gfc_simplify_maxval. + * simplify.c (min_max_choose): New function extracted from + simplify_min_max. + (simplify_min_max): Call it. + (simplify_minval_maxval, gfc_simplify_minval, + gfc_simplify_maxval): New functions. + + 2008-11-04 Paul Thomas + + PR fortran/37597 + * parse.c (gfc_fixup_sibling_symbols ): Fixup contained, even + when symbol not found. + + 2008-11-03 Tobias Burnus + + PR fortran/37821 + * cpp.c (gfc_cpp_add_include_path): Use BRACKET. + * scanner.c (add_path_to_list): Argument to add at head. + (gfc_add_include_path): Add new argument. + (gfc_add_intrinsic_modules_path) Update call. + (load_file): Print filename/line in the error message. + * gfortran.h (gfc_add_include_path): Update prototype. + * options.c (gfc_post_options,gfc_handle_module_path_options, + gfc_handle_option): Update call. + * lang-spec.h (F951_OPTIONS): Don't insert include path twice. + + * arith.c (arith_error): Add -fno-range-error to the message. + + 2008-11-03 Paul Thomas + + PR fortran/37445 + * resolve.c (resolve_actual_arglist ): Correct comparison of + FL_VARIABLE with e->expr_type. + (resolve_call): Check that host association is correct. + (resolve_actual_arglist ): Remove return is old_sym is use + associated. Only reparse expression if old and new symbols + have different types. + + PR fortran/PR35769 + * resolve.c (gfc_resolve_assign_in_forall): Change error to a + warning. + + 2008-11-01 Janus Weil + + PR fortran/36426 + * expr.c (replace_symbol): Replace all symbols which lie in the + formal namespace of the interface and copy their attributes. + * resolve.c (resolve_symbol): Add charlen to namespace. + + 2008-11-01 Steven G. Kargl + + PR fortran/19925 + * trans-array.c (gfc_trans_array_constructor_value): Fix comment. + (gfc_conv_array_initializer): Convert internal_error() to gfc_error_now. + * array.c: Remove GFC_MAX_AC_EXPAND macro. + (gfc_expand_constructor): Use gfc_option.flag_max_array_constructor. + * gfortran.h (gfc_option): Add flag_max_array_constructor member. + * lang.opt: Add -fmax-array-constructor option. + * expr.c (gfc_match_init_expr): Fix error message to mention new option. + * invoke.texi: Document new option. + * options.c (gfc_init_options): Set default value for new option. + (gfc_handle_option): Deal with commandline. + + 2008-11-01 Daniel Kraft + + PR fortran/35681 + * gfortran.h (struct gfc_code): New field `resolved_isym'. + * trans.h (gfc_build_memcpy_call): Made public. + * trans-array.h (gfc_trans_create_temp_array): New argument `initial'. + * intrinsic.c (gfc_intrinsic_sub_interface): Set resolved_isym. + * iresolve.c (create_formal_for_intents): New helper method. + (gfc_resolve_mvbits): Put dummy formal arglist on resolved_sym. + * resolve.c (resolve_call): Initialize resolved_isym to NULL. + * trans-array.c (gfc_trans_allocate_array_storage): New argument + `initial' to allow initializing the allocated storage to some initial + value copied from another array. + (gfc_trans_create_temp_array): Allow initialization of the temporary + with a copy of some other array by using the new extension. + (gfc_trans_array_constructor): Pass NULL_TREE for initial argument. + (gfc_conv_loop_setup): Ditto. + * trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Ditto. + * trans-expr.c (gfc_conv_function_call): Ditto. + (gfc_build_memcpy_call): Made public. + * trans-stmt.c (gfc_conv_elemental_dependencies): Initialize created + temporary for INTENT(INOUT) arguments to the value of the mirrored + array and clean up the temporary as very last intructions in the created + block. + * trans.c (gfc_trans_code): For EXEC_CALL, see if we have a MVBITS call + and enable elemental dependency checking if we have. + + 2008-11-01 Janus Weil + + PR fortran/36322 + PR fortran/36463 + * gfortran.h: New function gfc_expr_replace_symbols. + * decl.c (match_procedure_decl): Increase reference count for interface. + * expr.c: New functions replace_symbol and gfc_expr_replace_symbols. + * resolve.c (resolve_symbol): Correctly copy array spec and char len + of PROCEDURE declarations from their interface. + * symbol.c (gfc_get_default_type): Enhanced error message. + (copy_formal_args): Call copy_formal_args recursively for arguments. + * trans-expr.c (gfc_conv_function_call): Bugfix. + + 2008-11-01 Dennis Wassel + + PR fortran/37159 + * fortran/check.c (gfc_check_random_seed): Check PUT size + at compile time. + + 2008-10-31 Mikael Morin + + PR fortran/35840 + * expr.c (gfc_reduce_init_expr): New function, containing checking code + from gfc_match_init_expr, so that checking can be deferred. + (gfc_match_init_expr): Use gfc_reduce_init_expr. + * io.c (check_io_constraints): Use gfc_reduce_init_expr instead of + checking that the expression is a constant. + * match.h (gfc_reduce_init_expr): Prototype added. + + 2008-10-31 Mikael Morin + + PR fortran/35820 + * resolve.c (gfc_count_forall_iterators): New function. + (gfc_resolve_forall): Use gfc_count_forall_iterators to evaluate + the needed memory amount to allocate. Don't forget to free allocated + memory. Add an assertion to check for memory leaks. + + 2008-10-30 Steven G. Kargl + + PR fortran/37930 + * fortran/arith.c (gfc_mpfr_to_mpz): Test for NaN and Inf values. + Remove stale comment and kludge code for MPFR 2.0.1 and older. + (gfc_real2int): Error on conversion of NaN or Inf. + (gfc_complex2int): Ditto. + * fortran/arith.h: Update mpfr_to_mpz prototype. + * fortran/simplify.c (gfc_simplify_ceiling, gfc_simplify_floor, + gfc_simplify_ifix, gfc_simplify_idint, simplify_nint): Update function + calls to include locus. + + 2008-10-30 Mikael Morin + + PR fortran/37903 + * trans-array.c (gfc_trans_create_temp_array): If n is less + than the temporary dimension, assert that loop->from is + zero (reverts to earlier versions). If there is at least one + null loop->to[n], it is a callee allocated array so set the + size to NULL and break. + (gfc_trans_constant_array_constructor): Set the offset to zero. + (gfc_trans_array_constructor): Remove loop shifting around the + temporary creation. + (gfc_conv_loop_setup): Prefer zero-based descriptors if + possible. Calculate the translation from loop variables to + array indices if an array constructor. + + 2008-10-30 Mikael Morin + + PR fortran/37749 + * trans-array.c (gfc_trans_create_temp_array): If size is NULL + use the array bounds for loop->to. + + 2008-10-28 Tobias Burnus + + * intrinsic.texi: Update OpenMP section for OMPv3. + + 2008-10-24 Jakub Jelinek + + * Make-lang.in (check-f95-subtargets, check-fortran-subtargets): New + aliases for check-gfortran-subtargets. + (lang_checks_parallelized): Add check-gfortran. + (check_gfortran_parallelize): New variable. + + 2008-10-19 Paul Thomas + + PR fortran/37723 + * dependency.c (gfc_dep_resolver ): If we find equal array + element references, go on to the next reference. + + 2008-10-16 Daniel Kraft + + * resolve.c (resolve_elemental_actual): Handle calls to intrinsic + subroutines correctly. + + 2008-10-13 Kaveh R. Ghazi + + * simplify.c: Remove MPFR_VERSION_NUM(2,3,0) conditionals. + + 2008-10-12 Daniel Kraft + + PR fortran/37688 + * expr.c (gfc_expr_check_typed): Extend permission of untyped + expressions to both top-level variable and basic arithmetic expressions. + + 2008-10-12 Paul Thomas + + PR fortran/37787 + * dependency.c (gfc_are_equivalenced_arrays): Look in symbol + namespace rather than current namespace, if it is available. + + 2008-10-12 Steven G. Kargl + + PR fortran/37792 + * fortran/resolve.c (resolve_fl_variable): Simplify the + initializer if there is one. + + 2008-10-11 Paul Thomas + + PR fortran/37794 + * module.c (check_for_ambiguous): Remove redundant code. + + 2008-10-09 Daniel Kraft + + PR fortran/35723 + * gfortran.h (gfc_suppress_error): Removed from header. + (gfc_push_suppress_errors), (gfc_pop_suppress_errors): New methods. + * array.c (gfc_array_size): Use new gfc_push/pop_suppress_errors + instead of directly changing gfc_suppress_error. + * intrinsic.c (gfc_intrinsic_func_interface): Ditto. + (gfc_intrinsic_sub_interface): Ditto. + * error.c (suppress_errors): Made static from `gfc_suppress_error'. + (gfc_push_suppress_errors), (gfc_pop_suppress_errors): New methods. + (gfc_notify_std), (gfc_error): Use new static name of global. + * expr.c (check_arglist), (check_references): New methods. + (check_restricted): Check arglists and references of EXPR_FUNCTIONs + and EXPR_VARAIBALEs, respectively. Allow PARAMETER symbols. + + 2008-10-07 Jakub Jelinek + + * f95-lang.c (poplevel): Don't clear BLOCK_VARS if functionbody. + * trans-decl.c (gfc_build_qualified_array): Build accurate debug type + even if nest. + (build_entry_thunks, gfc_generate_function_code, + gfc_generate_constructors): Ensure DECL_SAVED_TREE is a BIND_EXPR + with DECL_INITIAL as its BLOCK. + + 2008-10-05 Paul Thomas + + PR fortran/35680 + * gfortran.h : Add 'error' bit field to gfc_expr structure. + * expr.c (check_inquiry): When checking a restricted expression + check that arguments are either variables or restricted. + (check_restricted): Do not emit error if the expression has + 'error' set. Clean up detection of host-associated variable. + + 2008-10-05 Daniel Kraft + + PR fortran/37638 + * gfortran.h (struct gfc_typebound_proc): New flag `error'. + * resolve.c (update_arglist_pass): Added assertion. + (update_compcall_arglist): Fail early for erraneous procedures to avoid + confusion later. + (resolve_typebound_generic_call): Ignore erraneous specific targets + and added assertions. + (resolve_typebound_procedure): Set new `error' flag. + + 2008-10-04 Paul Thomas + + PR fortran/37706 + * module.c (load_equiv): Check the module before negating the + unused flag. + + 2008-10-02 Steven Bosscher + + PR fortran/37635 + * intrinsic.c (add_functions): Add LEADZ and TRAILZ as generics. + * intrinsic.h (gfc_simplify_leadz, gfc_simplify_trailz): New protos. + * gfortran.h : (GFC_ISYM_LEADZ, GFC_ISYM_TRAILZ): New. + * f95-lang (gfc_init_builtin_functions): Add BUILT_IN_CLZ, + BUILT_IN_CLZL, BUILT_IN_CLZLL, BUILT_IN_CTZ, BUILT_IN_CTZL, and + BUILT_IN_CTZLL. + * trans-intrinsic.c (gfc_conv_intrinsic_leadz, + gfc_conv_intrinsic_trails): New code-generation functions for LEADZ + and TRAILZ intrinsics. + (gfc_conv_intrinsic_function): Use them + * intrinsic.texi: Add documentation for LEADZ and TRAILZ. + * simplify.c (gfc_simplify_leadz, gfc_simplify_trailz): New functions. + + 2008-09-30 Janus Weil + + PR fortran/36592 + * symbol.c (check_conflict): If a symbol in a COMMON block is a + procedure, it must be a procedure pointer. + (gfc_add_in_common): Symbols in COMMON blocks may be variables or + procedure pointers. + * trans-types.c (gfc_sym_type): Make procedure pointers in COMMON + blocks work. + + 2008-09-25 Jerry DeLisle + + PR fortran/37504 + * expr.c (gfc_check_pointer_assign): Allow assignment of + protected pointers. + * match.c (gfc_match_assignment,gfc_match_pointer_assignment): + Remove unreachable code. + + 2008-09-24 Tobias Burnus + + * options.c (set_default_std_flags,gfc_init_options): + Add comment: keep in sync with libgfortran. + + 2008-09-24 Tobias Burnus + + PR fortran/37626 + * trans-array.c (gfc_trans_deferred_array): Don't auto-deallocate + result variables. + + 2008-09-23 Daniel Kraft + + PR fortran/37588 + * gfortran.h (gfc_compare_actual_formal): Removed, made private. + (gfc_arglist_matches_symbol): New method. + * interface.c (compare_actual_formal): Made static. + (gfc_procedure_use): Use new name of compare_actual_formal. + (gfc_arglist_matches_symbol): New method. + (gfc_search_interface): Moved code partially to new + gfc_arglist_matches_symbol. + * resolve.c (resolve_typebound_generic_call): Resolve actual arglist + before checking against formal and use new gfc_arglist_matches_symbol + for checking. + (resolve_compcall): Set type-spec of generated expression. + + 2008-09-23 Tobias Burnus + + PR fortran/37580 + * expr.c (gfc_check_pointer_assign): Add checks for pointer + remapping. + + 2008-09-22 Jerry DeLisle + + PR fortran/37486 + * gfortran.h (gfc_option_t): New members flag_align_commons and + warn_align_commons. + * lang.opt: New options falign-commons and Walign-commons. + * invoke.texi: Documentation for new options. + * options.c (gfc_init_options): Initialize new options. + (gfc_handle_options): Handle new options. + * trans-common.c (translate_common): Implement new options. + (gfc_trans_common): Set correct locus. + + 2008-09-21 Paul Thomas + + PR fortran/37583 + * decl.c (scalarize_intrinsic_call): Both subroutines and + functions can give a true for get_proc_mame's last argument so + remove the &&gfc_current_ns->proc_name->attr.function. + resolve.c (resolve_actual_arglist): Add check for recursion by + reference to procedure as actual argument. + + 2008-09-21 Daniel Kraft + + PR fortran/35846 + * trans.h (gfc_conv_string_length): New argument `expr'. + * trans-expr.c (flatten_array_ctors_without_strlen): New method. + (gfc_conv_string_length): New argument `expr' that is used in a new + special case handling if cl->length is NULL. + (gfc_conv_subref_array_arg): Pass expr to gfc_conv_string_length. + * trans-array.c (gfc_conv_expr_descriptor): Ditto. + (gfc_trans_auto_array_allocation): Pass NULL as new expr. + (gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto. + (gfc_trans_deferred_array): Ditto. + (gfc_trans_array_constructor): Save and restore old values of globals + used for bounds checking. + * trans-decl.c (gfc_trans_dummy_character): Ditto. + (gfc_trans_auto_character_variable): Ditto. + + 2008-09-21 Daniel Kraft + + * decl.c (match_procedure_in_type): Changed misleading error message + for not yet implemented PROCEDURE(interface) syntax. + + 2008-09-18 Paul Thomas + + PR fortran/35945 + * resolve.c (resolve_fl_variable_derived): Remove derived type + comparison for use associated derived types. Host association + of a derived type will not arise if there is a local derived type + whose use name is the same. + + PR fortran/36700 + * match.c (gfc_match_call): Use the existing symbol even if + it is a function. + + 2008-09-18 Daniel Kraft + + PR fortran/37507 + * trans.h (gfc_trans_runtime_error): New method. + (gfc_trans_runtime_error_vararg): New method. + (gfc_allocate_array_with_status): New argument `expr' for locus/varname. + (gfc_deallocate_array_with_status): Ditto. + * trans-array.h (gfc_array_deallocate): Ditto. + * trans.c (gfc_trans_runtime_error): New method. + (gfc_trans_runtime_error_vararg): New method, moved parts of the code + from gfc_trans_runtime_check here. + (gfc_trans_runtime_error_check): Moved code partly to new method. + (gfc_call_malloc): Fix tab-indentation. + (gfc_allocate_array_with_status): New argument `expr' and call + gfc_trans_runtime_error for error reporting to include locus. + (gfc_deallocate_with_status): Ditto. + * trans-stmt.c (gfc_trans_deallocate): Pass expr as new argument. + * trans-array.c (gfc_array_allocate): Ditto. + (gfc_array_deallocate): New argument `expr', passed on. + (gfc_trans_dealloc_allocated): Pass NULL for expr. + * trans-openmp.c (gfc_omp_clause_default): Ditto. + + 2008-09-18 Paul Thomas + + PR fortran/37274 + PR fortran/36374 + * module.c (check_for_ambiguous): New function to test loaded + symbol for ambiguity with fixup symbol. + (read_module): Call check_for_ambiguous. + (write_symtree): Do not write the symtree for symbols coming + from an interface body. + + PR fortran/36374 + * resolve.c (count_specific_procs ): New function to count the + number of specific procedures with the same name as the generic + and emit appropriate errors for and actual argument reference. + (resolve_assumed_size_actual): Add new argument no_formal_args. + Correct logic around passing generic procedures as arguments. + Call count_specific_procs from two locations. + (resolve_function): Evaluate and pass no_formal_args. + (resolve call): The same and clean up a bit by using csym more + widely. + + PR fortran/36454 + * symbol.c (gfc_add_access): Access can be updated if use + associated and not private. + + 2008-09-17 Jakub Jelinek + + PR fortran/37536 + * trans-stmt.c (gfc_trans_do): Optimize integer type non-simple + do loop initialization. + + 2008-09-14 Jerry DeLisle + Tobias Burnus + + PR fortran/35840 + * io.c (match_vtag): Add tag name to error message. + (match_out_tag): Cleanup whitespace. + (gfc_resolve_dt): Resolve id and async tags. + + 2008-09-13 Daniel Kraft + + PR fortran/35770 + * primary.c (gfc_match_varspec): Added missing type-spec clearing + after wrong implicit character typing. + + 2008-09-12 Richard Guenther + + * trans-intrinsic.c (gfc_conv_intrinsic_transfer): Use + build_fold_addr_expr to properly mark the argument + addressable. + + 2008-09-11 Daniel Kraft + + PR fortran/36214 + * simplify.c (simplify_cmplx): Added linebreak to long line. + * target-memory.c (gfc_convert_boz): Fix indentation. + (gfc_interpret_float): Set mpfr precision to right value before + calling mpfr_init. + + 2008-09-10 H.J. Lu + + * expr.c (find_array_element): Reformat comment. + + 2008-09-10 H.J. Lu + + * expr.c (find_array_element): Reformat. + + 2008-09-10 Tobias Burnus + + PR fortran/37420 + * trans-decl.c (get_proc_pointer_decl): Fix -Wunused-variable. + + 2008-09-09 Daniel Kraft + + PR fortran/37429 + * resolve.c (expression_rank): Added assertion to guard against + EXPR_COMPCALL expressions. + (resolve_compcall): Set expression's rank from the target procedure's. + + 2008-09-09 Daniel Kraft + + PR fortran/37411 + * trans-array.c (gfc_conv_array_parameter): Added assertion that the + symbol has an array spec. + + 2008-09-08 Daniel Kraft + + PR fortran/37199 + * trans-expr.c (gfc_add_interface_mapping): Set new_sym->as. + (gfc_map_intrinsic_function): Added checks against NULL bounds in + array specs. + + 2008-09-08 Tobias Burnus + + PR fortran/37400 + * symbol.c (gfc_set_default_type): Copy char len. + + 2008-09-06 Steven G. Kargl + + PR fortran/36153 + * fortran/resolve.c (resolve_function): Shortcircuit for SIZE and + UBOUND if 2nd argument is KIND. + + 2008-09-06 Steven G. Kargl + + PR fortran/33229 + * resolve.c (resolve_function): An intrinsic subroutine should not be + called as a function. + + 2008-09-05 Daniel Kraft + + PR fortran/35837 + * resolve.c (resolve_types): Restore gfc_current_ns on exit. + * symbol.c (gfc_save_all): Removed blank line. + + 2008-09-05 Daniel Kraft + + PR fortran/36746 + * primary.c (gfc_match_rvalue): Removed logic to handle implicit + typing to a derived-type if a component reference is found. + (gfc_match_varspec): Moved it here. + + 2008-09-04 Richard Guenther + + * trans-array.c (gfc_conv_array_parameter): Use correct types + in building COND_EXPRs. + * trans-expr.c (gfc_conv_missing_dummy): Likewise. + * trans-intrinsics.c (gfc_conv_intrinsic_merge): Likewise. + + 2008-09-04 Daniel Kraft + + * PR fortran/37099 + * expr.c (simplify_const_ref): Update expression's character length + when pulling out a substring reference. + + 2008-09-04 Ian Lance Taylor + + * symbol.c (generate_isocbinding_symbol): Compare + gfc_notification_std with ERROR rather than FAILURE. + * resolve.c (check_assumed_size_reference): Compare array type + with AR_FULL rather than DIMEN_ELEMENT. + (resolve_actual_arglist): Compare with EXPR_VARIABLE rather than + FL_VARIABLE. + + 2008-09-01 Jerry DeLisle + + PR fortran/37228 + * io.c (check_format): Allow specifying precision with g0 format. + + 2008-09-02 Daniel Kraft + + * gfortran.h (struct gfc_namespace): New member `implicit_loc'. + (gfc_add_abstract): New method. + * decl.c (gfc_get_type_attr_spec): Match ABSTRACT attribute. + (gfc_match_derived_decl): Copy abstract attribute in derived symbol. + * dump-parse-tree.c (show_attr): Show ABSTRACT attribute as `ABSTRACT' + only to allow for ABSTRACT types. + * parse.c (parse_interface): Use new gfc_add_abstract. + * primary.c (gfc_match_structure_constructor): Check that no ABSTRACT + type is constructed. + * resolve.c (resolve_typespec_used): New method. + (resolve_fl_derived): Check type in respect to ABSTRACT attribute and + check that no component is of an ABSTRACT type. + (resolve_symbol): Check that no symbol is of an ABSTRACT type. + (resolve_types): Check IMPLICIT declarations for ABSTRACT types. + * symbol.c (gfc_merge_new_implicit): Remember loci of IMPLICIT's. + (gfc_add_abstract): New method. + + 2008-09-01 Daniel Kraft + + PR fortran/37193 + * module.c (read_module): Initialize use_only flag on used symbols. + + 2008-09-01 Daniel Kraft + + * gfc-internals.texi (F2003 OOP), (Type-bound Procedures): New chapter + and section to document the internals of type-bound procedures. + (gfc_expr): Document EXPR_COMPCALL. + * gfortran.h (struct gfc_expr): Remove unused `derived' from compcall. + * dump-parse-tree.c (show_compcall): New method. + (show_expr): Call it for EXPR_COMPCALL. + (show_typebound), (show_f2k_derived): New methods. + (show_symbol): Call show_f2k_derived. + (show_code_node): Handle EXEC_COMPCALL. + * primary.c (gfc_match_varspec): Don't initialize removed `derived' in + primary->value.compcall. + + 2008-08-31 Richard Guenther + + * trans-expr.c (gfc_trans_string_copy): Use the correct types + to compute slen and dlen. + + 2008-08-31 Daniel Kraft + + * gfortran.h (enum gfc_statement): New entry `ST_GENERIC'. + (struct gfc_tbp_generic): New type. + (struct gfc_typebound_proc): Removed `target' and added union with + `specific' and `generic' members; new members `overridden', + `subroutine', `function' and `is_generic'. + (struct gfc_expr): New members `derived' and `name' in compcall union + member and changed type of `tbp' to gfc_typebound_proc. + (gfc_compare_interfaces), (gfc_compare_actual_formal): Made public. + * match.h (gfc_typebound_default_access): New global. + (gfc_match_generic): New method. + * decl.c (gfc_match_generic): New method. + (match_binding_attributes): New argument `generic' and handle it. + (match_procedure_in_type): Mark matched binding as non-generic. + * interface.c (gfc_compare_interfaces): Made public. + (gfc_compare_actual_formal): Ditto. + (check_interface_1), (compare_parameter): Use new public names. + (gfc_procedure_use), (gfc_search_interface): Ditto. + * match.c (match_typebound_call): Set base-symbol referenced. + * module.c (binding_generic): New global array. + (current_f2k_derived): New global. + (mio_typebound_proc): Handle IO of GENERIC bindings. + (mio_f2k_derived): Record current f2k-namespace in current_f2k_derived. + * parse.c (decode_statement): Handle GENERIC statement. + (gfc_ascii_statement): Ditto. + (typebound_default_access), (set_typebound_default_access): Removed. + (gfc_typebound_default_access): New global. + (parse_derived_contains): New default-access implementation and handle + GENERIC statements encountered. + * primary.c (gfc_match_varspec): Adapted to new gfc_typebound_proc + structure and removed check for SUBROUTINE/FUNCTION from here. + * resolve.c (extract_compcall_passed_object): New method. + (update_compcall_arglist): Use it. + (resolve_typebound_static): Adapted to new gfc_typebound_proc structure. + (resolve_typebound_generic_call): New method. + (resolve_typebound_call): Check target is a SUBROUTINE and handle calls + to GENERIC bindings. + (resolve_compcall): Ditto (check for target being FUNCTION). + (check_typebound_override): Handle GENERIC bindings. + (check_generic_tbp_ambiguity), (resolve_typebound_generic): New methods. + (resolve_typebound_procedure): Handle GENERIC bindings and set new + attributes subroutine, function and overridden in gfc_typebound_proc. + (resolve_fl_derived): Ensure extended type is resolved before the + extending one is. + * st.c (gfc_free_statement): Fix bug with free'ing EXEC_COMPCALL's. + * symbol.c (gfc_find_typebound_proc): Adapt for GENERIC changes. + + 2008-08-29 Jan Hubicka + + * parse.c (parse_interface): Silence uninitialized var warning. + + 2008-08-29 Jakub Jelinek + + * trans.h (struct lang_type): Add span. + (GFC_TYPE_ARRAY_SPAN): Define. + * trans-decl.c (gfc_get_symbol_decl): For subref array pointers, + copy TREE_STATIC from decl to span instead of setting it + unconditionally, set DECL_ARTIFICIAL, fix type of initializer + and set GFC_TYPE_ARRAY_SPAN on decl's type. + * trans-types.c (gfc_get_array_descr_info): If + GFC_TYPE_ARRAY_SPAN is non-NULL, use it as element size. + + * trans-decl.c (check_constant_initializer, + gfc_emit_parameter_debug_info): New functions. + (gfc_generate_module_vars, gfc_generate_function_code): Emit + PARAMETERs and unreferenced variables with initializers into + debug info. + + * gfortran.h (gfc_use_list): Add where field. + * module.c (use_locus): New static variable. + (gfc_match_use): Set it. + (gfc_use_module): Copy it to gfc_use_list's where field. + * trans-decl.c (gfc_generate_module_vars): Call gfc_trans_use_stmts. + (gfc_trans_use_stmts): Set backend locus before calling the debug + hook. Allow non-VAR_DECLs to be created even for non-external + module. Don't emit anything so far for renames from different + modules. + + PR fortran/24790 + * trans-decl.c (create_function_arglist): Set DECL_BY_REFERENCE on + PARM_DECLs with pointer or reference type. + + * trans-decl.c (gfc_build_qualified_array): Build non-flat + array type for debug info purposes. + + PR fortran/29635 + PR fortran/23057 + * f95-lang.c (gfc_init_ts): New function. + (LANG_HOOKS_INIT_TS): Define. + * gfortran.h (gfc_use_rename): New type, moved from module.c. + (gfc_get_use_rename): New macro, moved from module.c. + (gfc_use_list): New type. + (gfc_get_use_list): New macro. + (gfc_namespace): Add use_stmts field. + (gfc_free_use_stmts): New prototype. + * Make-lang.in (fortran/trans-decl.o): Depend on debug.h. + * module.c (gfc_use_rename, gfc_get_use_rename): Moved to + gfortran.h. + (gfc_use_module): Chain the USE statement info to + ns->use_stmts. + (gfc_free_use_stmts): New function. + * symbol.c (gfc_free_namespace): Call gfc_free_use_stmts. + * trans.h (struct module_htab_entry): New type. + (gfc_find_module, gfc_module_add_decl): New functions. + * trans.c (gfc_generate_module_code): Create NAMESPACE_DECL for + the module, adjust DECL_CONTEXTs of module procedures and + call gfc_module_add_decl for them. + * trans-common.c (build_common_decl): Set DECL_IGNORED_P + on the common variable. + (create_common): Set DECL_IGNORED_P for use associated vars. + * trans-decl.c: Include debug.h. + (gfc_get_symbol_decl): Set DECL_IGNORED_P on use_assoc vars from + modules. + (build_function_decl): Allow current_function_decl's context + to be a NAMESPACE_DECL. + (module_htab, cur_module): New variables. + (module_htab_do_hash, module_htab_eq, module_htab_decls_hash, + module_htab_decls_eq, gfc_find_module, gfc_module_add_decl): New + functions. + (gfc_create_module_variable): Adjust DECL_CONTEXTs of module + variables and types and call gfc_module_add_decl for them. + (gfc_generate_module_vars): Temporarily set cur_module. + (gfc_trans_use_stmts): New function. + (gfc_generate_function_code): Call it. + (gfc_generate_block_data): Set DECL_IGNORED_P on decl. + * trans-types.c (gfc_get_derived_type): Adjust DECL_CONTEXT + and TYPE_CONTEXT of module derived types. + + 2008-08-28 Daniel Kraft + + * gfortran.h (enum expr_t): New value `EXPR_COMPCALL'. + (gfc_get_typebound_proc): New macro. + (struct gfc_expr): New union-member `compcall' for EXPR_COMPCALL. + (enum gfc_exec_op): New value `EXEC_COMPCALL'. + (gfc_find_typebound_proc): New argument. + (gfc_copy_ref), (gfc_match_varspec): Made public. + * decl.c (match_procedure_in_type): Use gfc_get_typebound_proc. + * expr.c (free_expr0), (gfc_copy_expr): Handle EXPR_COMPCALL. + (gfc_copy_ref): Made public and use new name. + (simplify_const_ref): Use new name of gfc_copy_ref. + (simplify_parameter_variable): Ditto. + (gfc_simplify_expr): gcc_unreachable for EXPR_COMPCALL. + * match.c (match_typebound_call): New method. + (gfc_match_call): Allow for CALL's to typebound procedures. + * module.c (binding_passing), (binding_overriding): New variables. + (expr_types): Add EXPR_COMPCALL. + (mio_expr): gcc_unreachable for EXPR_COMPCALL. + (mio_typebound_proc), (mio_typebound_symtree): New methods. + (mio_f2k_derived): Handle type-bound procedures. + * primary.c (gfc_match_varspec): Made public and parse trailing + references to type-bound procedures; new argument `sub_flag'. + (gfc_match_rvalue): New name and argument of gfc_match_varspec. + (match_variable): Ditto. + * resolve.c (update_arglist_pass): New method. + (update_compcall_arglist), (resolve_typebound_static): New methods. + (resolve_typebound_call), (resolve_compcall): New methods. + (gfc_resolve_expr): Handle EXPR_COMPCALL. + (resolve_code): Handle EXEC_COMPCALL. + (resolve_fl_derived): New argument to gfc_find_typebound_proc. + (resolve_typebound_procedure): Ditto and removed not-implemented error. + * st.c (gfc_free_statement): Handle EXEC_COMPCALL. + * symbol.c (gfc_find_typebound_proc): New argument `noaccess' and + implement access-checking. + * trans-expr.c (gfc_apply_interface_mapping_to_expr): gcc_unreachable + on EXPR_COMPCALL. + * trans-intrinsic.c (gfc_conv_intrinsic_bound): Add missing break. + * trans-openmp.c (gfc_trans_omp_array_reduction): Add missing + intialization of ref->type. + + 2008-08-28 Janus Weil + + PR fortran/37253 + * module.c (ab_attribute,attr_bits,mio_symbol_attribute): Take care of + saving attr.procedure and attr.proc_ptr to the module file. + + 2008-08-25 Daniel Kraft + + * gfortran.h (gfc_find_component): Add new arguments. + * parse.c (parse_derived_contains): Check if the derived-type containing + the CONTAINS section is SEQUENCE/BIND(C). + * resolve.c (resolve_typebound_procedure): Check for name collision with + components. + (resolve_fl_derived): Check for name collision with inherited + type-bound procedures. + * symbol.c (gfc_find_component): New arguments `noaccess' and `silent'. + (gfc_add_component): Adapt for new arguments. + * primary.c (match_varspec), (gfc_match_structure_constructor): Ditto. + + 2008-08-24 Tobias Burnus + + PR fortran/37201 + * decl.c (verify_bind_c_sym): Reject array/string returning + functions. + + 2008-08-24 Tobias Burnus + + PR fortran/37201 + * trans-expr.c (gfc_conv_function_call): Add string_length + for character-returning bind(C) functions. + + 2008-08-24 Daniel Kraft + + * gfortran.h (gfc_typebound_proc): New struct. + (gfc_symtree): New member typebound. + (gfc_find_typebound_proc): Prototype for new method. + (gfc_get_derived_super_type): Prototype for new method. + * parse.h (gfc_compile_state): New state COMP_DERIVED_CONTAINS. + * decl.c (gfc_match_procedure): Handle PROCEDURE inside derived-type + CONTAINS section. + (gfc_match_end): Handle new context COMP_DERIVED_CONTAINS. + (gfc_match_private): Ditto. + (match_binding_attributes), (match_procedure_in_type): New methods. + (gfc_match_final_decl): Rewrote to make use of new + COMP_DERIVED_CONTAINS parser state. + * parse.c (typebound_default_access): New global helper variable. + (set_typebound_default_access): New callback method. + (parse_derived_contains): New method. + (parse_derived): Extracted handling of CONTAINS to new parser state + and parse_derived_contains. + * resolve.c (resolve_bindings_derived), (resolve_bindings_result): New. + (check_typebound_override), (resolve_typebound_procedure): New methods. + (resolve_typebound_procedures): New method. + (resolve_fl_derived): Call new resolving method for typebound procs. + * symbol.c (gfc_new_symtree): Initialize new member typebound to NULL. + (gfc_find_typebound_proc): New method. + (gfc_get_derived_super_type): New method. + + 2008-08-23 Janus Weil + + * gfortran.h (gfc_component): Add field "symbol_attribute attr", remove + fields "pointer", "allocatable", "dimension", "access". + Remove functions "gfc_set_component_attr" and "gfc_get_component_attr". + * interface.c (gfc_compare_derived_types): Ditto. + * trans-array.c (gfc_array_allocate,structure_alloc_comps): Ditto. + * trans-expr.c (gfc_conv_component_ref,gfc_trans_subcomponent_assign, + gfc_conv_structure): Ditto. + * symbol.c (gfc_find_component,free_components,gfc_set_component_attr, + gfc_get_component_attr,verify_bind_c_derived_type, + generate_isocbinding_symbol): Ditto. + * decl.c (build_struct): Ditto. + * dump-parse-tree.c (show_components): Ditto. + * trans-stmt.c (gfc_trans_deallocate): Ditto. + * expr.c (gfc_check_assign,gfc_check_pointer_assign, + gfc_default_initializer): Ditto. + * module.c (mio_component): Ditto. + * trans-types.c (copy_dt_decls_ifequal,gfc_get_derived_type): Ditto. + * resolve.c (has_default_initializer,resolve_structure_cons, + gfc_iso_c_func_interface,find_array_spec,resolve_ref, + resolve_deallocate_expr,resolve_allocate_expr,resolve_fl_derived, + resolve_equivalence_derived): Ditto. + * trans-io.c (transfer_expr): Ditto. + * parse.c (parse_derived): Ditto. + * dependency.c (gfc_check_dependency): Ditto. + * primary.c (gfc_variable_attr): Ditto. + + 2008-08-23 Tobias Burnus + + PR fortran/37076 + * arith.c (gfc_arith_concat): Fix concat of kind=4 strings. + + 2008-08-23 Tobias Burnus + + PR fortran/37025 + * target-memory.c (gfc_interpret_character): Support + kind=4 characters. + + 2008-08-22 Daniel Kraft + + PR fortran/30239 + * symbol.c (gfc_add_type): Warn on -Wsurprising if a function-result + type is re-declared but neither -pedantic nor -std=f* is given and so + this is no error. + * invoke.texi (-Wsurprising): Document this new behaviour. + + 2008-08-22 Daniel Kraft + + * gfortran.h (in_prefix): Removed from this header. + * match.h (gfc_matching_prefix): Moved and renamed from `in_prefix'. + * decl.c (in_prefix): Removed from here. + (gfc_match_prefix): Use new name of `gfc_matching_prefix'. + * symbol.c (gfc_check_symbol_typed): Ditto. + * expr.c (check_typed_ns): New helper variable. + (expr_check_typed_help): New helper method. + (gfc_expr_check_typed): Rewrote to use gfc_traverse_expr to do the + work, fixing a minor problem. + * match.c (gfc_matching_prefix): New variable. + + 2008-08-22 Daniel Kraft + + PR fortran/32095 + PR fortran/34228 + * gfortran.h (in_prefix): New global. + (gfc_check_symbol_typed), (gfc_check_expr_typed): New methods. + * array.c (match_array_element_spec): Check that bounds-expressions + don't have symbols not-yet-typed in them. + * decl.c (var_element): Check that variable used is already typed. + (char_len_param_value): Check that expression does not contain + not-yet-typed symbols. + (in_prefix): New global. + (gfc_match_prefix): Record using `in_prefix' if we're at the moment + parsing a prefix or not. + * expr.c (gfc_expr_check_typed): New method. + * parse.c (verify_st_order): New argument to disable error output. + (check_function_result_typed): New helper method. + (parse_spec): Check that the function-result declaration, if given in + a prefix, contains no not-yet-typed symbols when the IMPLICIT rules are + parsed. + * symbol.c (gfc_check_symbol_typed): Check that a symbol already has + a type associated to it, otherwise use the IMPLICIT rules or signal + an error. + + 2008-08-21 Manuel Lopez-Ibanez + + * f95-lang.c: Update all calls to pedwarn. + + 2008-08-18 Daniel Franke + + PR fortran/37032 + * gfortran.texi: Document decision on include file handling in + preprocessed files. + + 2008-08-16 Tobias Burnus + + PR fortran/36825 + * libgfortran.h: Reduce GFC_MAX_DIMENSIONS to 7. + + 2008-08-15 Jerry DeLisle + + PR fortran/35863 + * io.c (gfc_match_open): Enable UTF-8 in checks. + * simplify.c (gfc_simplify_selected_char_kind): Enable iso_10646. + + 2008-08-14 Janus Weil + + PR fortran/36705 + * symbol.c (check_conflict): Move conflict checks for (procedure,save) + and (procedure,intent) to resolve_fl_procedure. + * resolve.c (resolve_fl_procedure): Ditto. + + 2008-08-09 Manuel Lopez-Ibanez + + PR 36901 + * f95-lang.c (gfc_mark_addressable): Use "pedwarn (0," instead of + 'pedwarn0'. + + 2008-08-09 Paul Thomas + + PR fortran/37011 + * symbol.c (gfc_add_extension): New function. + * decl.c (gfc_get_type_attr_spec): Call it. + (gfc_match_derived_decl): Set symbol extension attribute from + attr.extension. + * gfortran.h : Add prototype for gfc_add_extension. + + 2008-08-08 Manuel Lopez-Ibanez + + PR 28875 + * options.c (set_Wall): Replace set_Wunused by warn_unused. + + 2008-08-08 Daniel Kraft + + * gfortran.h (gfc_finalizer): Replaced member `procedure' by two + new members `proc_sym' and `proc_tree' to store the symtree after + resolution. + (gfc_find_sym_in_symtree): Made public. + * decl.c (gfc_match_final_decl): Adapted for new member name. + * interface.c (gfc_find_sym_in_symtree): Made public. + (gfc_extend_expr), (gfc_extend_assign): Changed call accordingly. + * module.c (mio_finalizer), (mio_f2k_derived), (mio_full_f2k_derived): + New methods for module-file IO of f2k_derived. + (mio_symbol): Do IO of f2k_derived namespace. + * resolve.c (gfc_resolve_finalizers): Adapted for new member name and + finding the symtree for the symbol here. + * symbol.c (gfc_free_finalizer): Adapted for new members. + + 2008-07-30 Ralf Wildenhues + + * gfc-internals.texi: Update to GFDL 1.2. Do not list GPL as + Invariant Section. + * gfortran.texi: Likewise. + * intrinsic.texi: Do not list GPL as Invariant Section. + * invoke.texi: Likewise. Update copyright years. + + 2008-07-29 Paul Thomas + + * trans-expr.c (conv_parent_component_references): New function + to build missing parent references. + (gfc_conv_variable): Call it + * symbol.c (gfc_add_component): Check that component name in a + derived type extension does not appear in parent. + (gfc_find_component): For a derived type extension, check if + the component appears in the parent derived type by calling + self. Separate errors for private components and private types. + * decl.c (match_data_constant): Add extra arg to call to + gfc_match_structure_constructor. + (check_extended_derived_type): New function to check that a + parent derived type exists and that it is OK for exension. + (gfc_get_type_attr_spec): Add extra argument 'name' and return + it if extends is specified. + (gfc_match_derived_decl): Match derived type extension and + build a first component of the parent derived type if OK. Add + the f2k namespace if not present. + * gfortran.h : Add the extension attribute. + * module.c : Handle attribute 'extension'. + * match.h : Modify prototypes for gfc_get_type_attr_spec and + gfc_match_structure_constructor. + * primary.c (build_actual_constructor): New function extracted + from gfc_match_structure_constructor and modified to call self + iteratively to build derived type extensions, when f2k named + components are used. + (gfc_match_structure_constructor): Do not throw error for too + many components if a parent type is being handled. Use + gfc_find_component to generate errors for non-existent or + private components. Iteratively call self for derived type + extensions so that parent constructor is built. If extension + and components left over, throw error. + (gfc_match_rvalue): Add extra arg to call to + gfc_match_structure_constructor. + + * trans-array.c (gfc_conv_resolve_dependencies): If lhs and rhs + are the same symbol, aliassing does not matter. + + 2008-07-29 Jan Hubicka + + * options.c (gfc_post_options): Do not set flag_no_inline. + + 2008-07-29 Daniel Kraft + + PR fortran/36403 + * trans-intrinsic.c (conv_generic_with_optional_char_arg): New method + to append a string-length even if the string argument is missing, e.g. + for EOSHIFT. + (gfc_conv_intrinsic_function): Call the new method for EOSHIFT, PACK + and RESHAPE. + + 2008-07-28 Kaveh R. Ghazi + + * gfortran.h (try): Remove macro. Replace try with gfc_try + throughout. + * array.c: Likewise. + * check.c: Likewise. + * cpp.c: Likewise. + * cpp.h: Likewise. + * data.c: Likewise. + * data.h: Likewise. + * decl.c: Likewise. + * error.c: Likewise. + * expr.c: Likewise. + * interface.c: Likewise. + * intrinsic.c: Likewise. + * intrinsic.h: Likewise. + * io.c: Likewise. + * match.h: Likewise. + * parse.c: Likewise. + * parse.h: Likewise. + * resolve.c: Likewise. + * scanner.c: Likewise. + * simplify.c: Likewise. + * symbol.c: Likewise. + * trans-openmp.c: Likewise. + * trans-types.c: Likewise. + + 2008-07-28 Tobias Burnus + + * Make-lang.in: Remove -Wno-* from fortran-warn. + + 2008-07-28 Richard Guenther + + Merge from gimple-tuples-branch. + + 2008-07-18 Aldy Hernandez + + * trans-expr.c: Include gimple.h instead of tree-gimple.h. + * trans-array.c: Same. + * trans-openmp.c: Same. + * trans-stmt.c: Same. + * f95-lang.c: Same. + * trans-io.c: Same. + * trans-decl.c: Same. + * trans-intrinsic.c: Same. + * trans.c: Same. Include tree-iterator.h. + * Make-lang.in (trans.o): Depend on tree-iterator.h + + 2008-07-14 Aldy Hernandez + + * trans-array.h (gfc_conv_descriptor_data_set_internal): + Rename to gfc_conv_descriptor_data_set. + (gfc_conv_descriptor_data_set_tuples): Remove. + * trans-array.c (gfc_conv_descriptor_data_get): Rename + from gfc_conv_descriptor_data_set_internal. + Remove last argument to gfc_add_modify. + (gfc_trans_allocate_array_storage): Rename gfc_add_modify_expr to + gfc_add_modify. + (gfc_trans_create_temp_array): Same. + (gfc_conv_array_transpose): Same. + (gfc_grow_array): Same. + (gfc_put_offset_into_var): Same. + (gfc_trans_array_ctor_element): Same. + (gfc_trans_array_constructor_subarray): Same. + (gfc_trans_array_constructor_value): Same. + (gfc_trans_scalarized_loop_end): Same. + (gfc_array_init_size): Same. + (gfc_array_allocate): Same. + (gfc_trans_array_bounds): Same. + (gfc_trans_auto_array_allocation): Same. + (gfc_trans_g77_array): Same. + (gfc_trans_dummy_array_bias): Same. + (gfc_conv_expr_descriptor): Same. + (structure_alloc_comps): Same. + * trans-expr.c: Same. + * trans-openmp.c (gfc_omp_clause_default_ctor): Same. + Rename gfc_conv_descriptor_data_set_tuples to + gfc_conv_descriptor_data_set. + (gfc_omp_clause_copy_ctor): Change build_gimple_modify_stmt to + build2_v. + (gfc_omp_clause_assign_op): Same. + (gfc_trans_omp_array_reduction): Rename gfc_add_modify_expr to + gfc_add_modify. + (gfc_trans_omp_atomic): Same. + (gfc_trans_omp_do): Same. Change GIMPLE_MODIFY_STMT to MODIFY_EXPR. + Rename gfc_add_modify_stmt to gfc_add_modify. + * trans-stmt.c: Rename gfc_add_modify_expr to + gfc_add_modify. + * trans.c: Rename gfc_add_modify_expr to + gfc_add_modify. + (gfc_add_modify): Remove last argument. + Rename GIMPLE_MODIFY_STMT to MODIFY_EXPR. + * trans.h: Remove gfc_add_modify_expr, gfc_add_modify_stmt. + Add prototype for gfc_add_modify. + * f95-lang.c (union lang_tree_node): Rename GENERIC_NEXT to TREE_CHAIN. + * trans-decl.c: Rename gfc_add_modify_stmt to gfc_add_modify. + * trans-io.c: Same. + * trans-intrinsic.c: Same. + + 2008-02-25 Aldy Hernandez + + * Make-lang.in (fortran-warn): Add -Wno-format. + + 2008-02-19 Diego Novillo + + http://gcc.gnu.org/ml/gcc-patches/2008-02/msg00804.html + + * fortran/Make-lang.in (fortran-warn): Remove. + + 2007-11-22 Aldy Hernandez + + * trans-expr.c (gfc_trans_string_copy): Use "void *" when building a + memset. + + 2007-11-10 Aldy Hernandez + + * Make-lang.in (fortran-warn): Set to -Wno-format. + * trans.c (gfc_trans_code): Update comment to say GENERIC. + Call tree_annotate_all_with_locus instead of annotate_all_with_locus. + + 2008-07-27 Tobias Burnus + + PR fortran/36132 + PR fortran/29952 + PR fortran/36909 + * trans.c (gfc_trans_runtime_check): Allow run-time warning besides + run-time error. + * trans.h (gfc_trans_runtime_check): Update declaration. + * trans-array.c (gfc_trans_array_ctor_element,gfc_trans_array_bound_check, + gfc_conv_array_ref,gfc_conv_ss_startstride,gfc_trans_dummy_array_bias): + Updated gfc_trans_runtime_check calls. + (gfc_conv_array_parameter): Implement flag_check_array_temporaries, + fix packing/unpacking for nonpresent optional actuals to optional + formals. + * trans-array.h (gfc_conv_array_parameter): Update declaration. + * trans-expr.c (gfc_conv_substring,gfc_trans_arrayfunc_assign, + gfc_conv_function_call): Updated gfc_trans_runtime_check calls. + (gfc_conv_function_call): Update gfc_conv_array_parameter calls. + * trans-expr.c (gfc_trans_goto): Updated gfc_trans_runtime_check + calls. + * trans-io.c (set_string,gfc_conv_intrinsic_repeat): Ditto. + (gfc_conv_intrinsic_transfer,gfc_conv_intrinsic_loc): Same for + gfc_conv_array_parameter. + * trans-intrinsics.c (gfc_conv_intrinsic_bound): Ditto. + * trans-decl.c (gfc_build_builtin_function_decls): Add + gfor_fndecl_runtime_warning_at. + * lang.opt: New option fcheck-array-temporaries. + * gfortran.h (gfc_options): New flag_check_array_temporaries. + * options.c (gfc_init_options, gfc_handle_option): Handle flag. + * invoke.texi: New option fcheck-array-temporaries. + + 2008-07-24 Jan Hubicka + + * fortran/options.c (gfc_post_options): Remove flag_unline_trees code. + + 2008-07-24 Daniel Kraft + + PR fortran/33141 + * lang.opt (Wnonstd-intrinsics): Removed option. + (Wintrinsics-std), (Wintrinsic-shadow): New options. + * invoke.texi (Option Summary): Removed -Wnonstd-intrinsics + from the list and added -Wintrinsics-std and -Wintrinsic-shadow. + (Error and Warning Options): Documented the new options and removed + the documentation for -Wnonstd-intrinsics. + * gfortran.h (gfc_option_t): New members warn_intrinsic_shadow and + warn_intrinsics_std, removed warn_nonstd_intrinsics. + (gfc_is_intrinsic): Renamed from gfc_intrinsic_name. + (gfc_warn_intrinsic_shadow), (gfc_check_intrinsic_standard): New. + * decl.c (match_procedure_decl): Replaced gfc_intrinsic_name by + the new name gfc_is_intrinsic. + (warn_intrinsic_shadow): New helper method. + (gfc_match_function_decl), (gfc_match_subroutine): Call the new method + warn_intrinsic_shadow to check the just-parsed procedure. + * expr.c (check_init_expr): Call new gfc_is_intrinsic to check whether + the function called is really an intrinsic in the selected standard. + * intrinsic.c (gfc_is_intrinsic): Renamed from gfc_intrinsic_name and + extended to take into account the selected standard settings when trying + to find out whether a symbol is an intrinsic or not. + (gfc_check_intrinsic_standard): Made public and extended. + (gfc_intrinsic_func_interface), (gfc_intrinsic_sub_interface): Removed + the calls to check_intrinsic_standard, this check now happens inside + gfc_is_intrinsic. + (gfc_warn_intrinsic_shadow): New method defined. + * options.c (gfc_init_options): Initialize new warning flags to false + and removed intialization of Wnonstd-intrinsics flag. + (gfc_post_options): Removed logic for Wnonstd-intrinsics flag. + (set_Wall): Set new warning flags and removed Wnonstd-intrinsics flag. + (gfc_handle_option): Handle the new flags and removed handling of the + old Wnonstd-intrinsics flag. + * primary.c (gfc_match_rvalue): Replaced call to gfc_intrinsic_name by + the new name gfc_is_intrinsic. + * resolve.c (resolve_actual_arglist): Ditto. + (resolve_generic_f), (resolve_unknown_f): Ditto. + (is_external_proc): Ditto. + (resolve_generic_s), (resolve_unknown_s): Ditto. + (resolve_symbol): Ditto and ensure for symbols declared INTRINSIC that + they are really available in the selected standard setting. + + 2008-07-24 Daniel Kraft + + * match.c (gfc_match): Add assertion to catch wrong calls trying to + match upper-case characters. + + 2008-07-24 Thomas Koenig + + PR fortran/29952 + * gfortran.h: Add "warn_array_temp" to gfc_option_t. + * lang.opt: Add -Warray-temporaries. + * invoke.texi: Document -Warray-temporaries + * trans-array.h (gfc_trans_create_temp_array): Add argument of + type *locus. + (gfc_conv_loop_setup): Likewise. + * trans-array.c (gfc_trans_create_temp_array): If + -Warray-temporaries is given and locus is present, warn about + creation of array temporaries. + (gfc_trans_array_constructor_subarray): Add locus to call + of gfc_conv_loop_setup. + (gfc_trans_array_constructor): Add where argument. Pass where + argument to call of gfc_trans_create_temp_array. + (gfc_add_loop_ss_code): Add where argument. Pass where argument + to recursive call of gfc_add_loop_ss_code and to call of + gfc_trans_array_constructor. + (gfc_conv_loop_setup): Add where argument. Pass where argument + to calls to gfc_add_loop_ss_code and to gfc_trans_create_temp_array. + (gfc_conv_expr_descriptor): Pass location to call of + gfc_conv_loop_setup. + (gfc_conv_array_parameter): If -Warray-temporaries is given, + warn about creation of temporary arrays. + * trans-expr.c (gfc_conv_subref_array_arg): Add where argument + to call to gfc_conv_loop_setup. + (gfc_conv_function_call): Add where argument to call to + gfc_trans_creat_temp_array. + (gfc_trans_subarray_assign): Likewise. + (gfc_trans_assignment_1): Add where argument to call to + gfc_conv_loop_setup. + * trans-stmt.c (gfc_conv_elemental_dependencies): Add where + argument to call to gfc_trans_create_temp_array. + (gfc_trans_call): Add where argument to call to gfc_conv_loop_setup. + (generate_loop_for_temp_to_lhs): Likewise. + (generate_loop_for_rhs_to_temp): Likewise. + (compute_inner_temp_size): Likewise. + (gfc_trans-pointer_assign_need_temp): Likewise. + (gfc_evaluate_where_mask): Likewise. + (gfc_trans_where_assign): Likewise. + (gfc_trans_where_3): Likewise. + * trans-io.c (transfer_srray_component): Add where argument + to function. Add where argument to call to gfc_conv_loop_setup. + (transfer_expr): Add where argument to call to + transfer_array_component. + (gfc_trans_transfer): Add where expression to call to + gfc_conv_loop_setup. + * trans-intrinsic.c (gfc_conv_intrinsic_anyall): Add + where argument to call to gfc_conv_loop_setup. + (gfc_conv_intrinsic_count): Likewise. + (gfc_conv_intrinsic_arith): Likewise. + (gfc_conv_intrinsic_dot_product): Likewise. + (gfc_conv_intrinsic_minmaxloc): Likewise. + (gfc_conv_intrinsic_minmaxval): Likewise. + (gfc_conv_intrinsic_array_transfer): Warn about + creation of temporary array. + Add where argument to call to gfc_trans_create_temp_array. + * options.c (gfc_init_options): Initialize gfc_option.warn_array_temp. + (gfc_handle_option): Set gfc_option.warn_array_temp. + + 2008-07-23 Manuel Lopez-Ibanez + + PR 35058 + * f95-lang.c (gfc_mark_addressable): All calls to pedwarn changed. + + 2008-07-22 Daniel Kraft + + PR fortran/29835 + * io.c (error_element), (format_locus): New static globals. + (unexpected_element): Spelled out this message fully. + (next_char): Keep track of locus when not MODE_STRING. + (next_char_not_space): Remember last parsed element in error_element. + (format_lex): Fix two indentation errors. + (check_format): Use format_locus and possibly error_element for a + slightly better error message on invalid format. + (check_format_string): Set format_locus to start of the string + expression used as format. + + 2008-07-21 Ralf Wildenhues + + * expr.c (gfc_check_pointer_assign): Fix typo in string. + * io.c (check_format): Fix typo in string. Fix comment typos. + * parse.c (gfc_global_used): Likewise. + * resolve.c (resolve_allocate_expr): Likewise. + * symbol.c (gfc_set_default_type): Likewise. + * arith.c: Fix typos in comments. + * array.c: Likewise. + * data.c: Likewise. + * decl.c: Likewise. + * dependency.c: Likewise. + * f95-lang.c: Likewise. + * gfortran.h: Likewise. + * matchexp.c: Likewise. + * module.c: Likewise. + * primary.c: Likewise. + * scanner.c: Likewise. + * trans-array.c: Likewise. + * trans-common.c: Likewise. + * trans-decl.c: Likewise. + * trans-expr.c: Likewise. + * trans-intrinsic.c: Likewise. + * trans-types.c: Likewise. + * trans.c: Likewise. + * trans.h: Likewise. + + 2008-07-19 Tobias Burnus + + PR fortran/36795 + * matchexp.c (gfc_get_parentheses): Remove obsolete workaround, + which caused the generation of wrong code. + + 2008-07-19 Tobias Burnus + + PR fortran/36342 + * scanner.c (load_file): Add argument to destinguish between + true filename and displayed filename. + (include_line,gfc_new_file): Adapt accordingly. + + 2008-07-19 Tobias Burnus + + * check.c (gfc_check_cshift,gfc_check_eoshift,gfc_check_unpack): Add rank + checks for cshift's shift and eoshift's shift and boundary args. + (gfc_check_unpack): Add rank and shape tests for unpack. + + 2008-07-19 Kaveh R. Ghazi + + * gfortran.h (new): Remove macro. + * array.c (gfc_append_constructor, match_array_list, + gfc_match_array_constructor): Likewise. + * bbt.c (insert, gfc_insert_bbt): Likewise. + * decl.c (var_element, top_var_list, top_val_list, gfc_match_data, + get_proc_name): Likewise. + * expr.c (gfc_copy_actual_arglist): Likewise. + * interface.c (compare_actual_formal, check_new_interface, + gfc_add_interface): Likewise. + * intrinsic.c gfc_convert_type_warn, gfc_convert_chartype): + Likewise. + * io.c (match_io_iterator, match_io_list): Likewise. + * match.c (match_forall_header): Likewise. + * matchexp.c (build_node): Likewise. + * module.c (gfc_match_use): Likewise. + * scanner.c (load_file): Likewise. + * st.c (gfc_append_code): Likewise. + * symbol.c (save_symbol_data, gfc_get_sym_tree, gfc_undo_symbols, + gfc_commit_symbols): Likewise. + * trans-common.c (build_field): Likewise. + * trans-decl.c (gfc_finish_var_decl): Likewise. + * trans-expr.c (gfc_free_interface_mapping, + gfc_get_interface_mapping_charlen, gfc_add_interface_mapping, + gfc_finish_interface_mapping, + gfc_apply_interface_mapping_to_expr): Likewise. + * trans.h (gfc_interface_sym_mapping): Likewise. + + 2008-07-19 Kaveh R. Ghazi + + * gfortran.h (operator): Remove macro. + (gfc_namespace, gfc_expr): Avoid C++ keywords. + * arith.c (eval_intrinsic, eval_intrinsic_f2, eval_intrinsic_f3): + Likewise. + * decl.c (access_attr_decl): Likewise. + * dependency.c (gfc_dep_compare_expr): Likewise. + * dump-parse-tree.c (show_expr, show_uop, show_namespace): + Likewise. + * expr.c (gfc_copy_expr, gfc_type_convert_binary, + simplify_intrinsic_op, check_intrinsic_op): Likewise. + * interface.c (fold_unary, gfc_match_generic_spec, + gfc_match_interface, gfc_match_end_interface, + check_operator_interface, check_uop_interfaces, + gfc_check_interfaces, gfc_extend_expr, gfc_extend_assign, + gfc_add_interface, gfc_current_interface_head, + gfc_set_current_interface_head): Likewise. + * iresolve.c (gfc_resolve_dot_product, gfc_resolve_matmul): + Likewise. + * matchexp.c (gfc_get_parentheses, build_node): Likewise. + * module.c (gfc_use_rename, gfc_match_use, find_use_name_n, + number_use_names, mio_expr, load_operator_interfaces, read_module, + write_operator, write_module): Likewise. + * openmp.c (resolve_omp_atomic): Likewise. + * resolve.c (resolve_operator, gfc_resolve_character_operator, + gfc_resolve_uops): Likewise. + * symbol.c (free_uop_tree, gfc_free_namespace): Likewise. + * trans-expr.c (gfc_conv_expr_op): Likewise. + * trans-openmp.c (gfc_trans_omp_atomic): Likewise. + + 2008-07-19 Kaveh R. Ghazi + + * gfortran.h (protected): Remove macro. + * dump-parse-tree.c (show_attr): Avoid C++ keywords. + * expr.c (gfc_check_pointer_assign): Likewise. + * interface.c (compare_parameter_protected): Likewise. + * intrinsic.c (enum class, add_sym, add_sym_0, add_sym_1, + add_sym_1s, add_sym_1m, add_sym_2, add_sym_2s, add_sym_3, + add_sym_3ml, add_sym_3red, add_sym_3s, add_sym_4, add_sym_4s, + add_sym_5s): Likewise. + * match.c (gfc_match_assignment, gfc_match_pointer_assignment): + Likewise. + * module.c (mio_symbol_attribute): Likewise. + * primary.c (match_variable): Likewise. + * resolve.c (resolve_equivalence): Likewise. + * symbol.c (check_conflict, gfc_add_protected, gfc_copy_attr): + Likewise. + * trans-types.c (gfc_get_array_type_bounds): Likewise. + + 2008-07-18 Kaveh R. Ghazi + + * arith.c (eval_type_intrinsic0): Avoid C++ keywords. + * gfortran.h (try, protected, operator, new): Likewise. + + 2008-07-17 Tobias Burnus + + PR fortran/36825 + PR fortran/36824 + * array.c (gfc_match_array_spec): Fix array-rank check. + * resolve.c (resolve_fl_derived): Fix constentness check + for the array dimensions. + + 2008-07-14 Ralf Wildenhues + + * Make-lang.in (gfortranspec.o): Fix dependencies. + + 2008-07-13 Jerry DeLisle + + PR fortran/36725 + * io.c: Add error check for g0 edit descriptor followed by '.'. + + 2008-07-12 Daniel Kraft + + * resolve.c (resolve_fl_derived): Allow pointer components to empty + derived types fixing a missing part of PR fortran/33221. + + 2008-07-10 Daniel Kraft + + * gfc-internals.texi (section gfc_expr): Created documentation about + the gfc_expr internal data structure. + + 2008-07-07 Thomas Koenig + + PR fortran/36670 + * iresolve.c (gfc_resolve_product): Set shape of return + value from array. + (gfc_resolve_sum): Likewise. + + 2008-07-07 Jakub Jelinek + + PR middle-end/36726 + * f95-lang.c (poplevel): Don't ever add subblocks to + global_binding_level. + + 2008-07-02 Janus Weil + Tobias Burnus + Paul Thomas + + PR fortran/32580 + * gfortran.h (struct gfc_symbol): New member "proc_pointer". + * check.c (gfc_check_associated,gfc_check_null): Implement + procedure pointers. + * decl.c (match_procedure_decl): Ditto. + * expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol): Ditto. + * interface.c (compare_actual_formal): Ditto. + * match.h: Ditto. + * match.c (gfc_match_pointer_assignment): Ditto. + * parse.c (parse_interface): Ditto. + * primary.c (gfc_match_rvalue,match_variable): Ditto. + * resolve.c (resolve_fl_procedure): Ditto. + * symbol.c (check_conflict,gfc_add_external,gfc_add_pointer, + gfc_copy_attr,gen_fptr_param,build_formal_args): Ditto. + * trans-decl.c (get_proc_pointer_decl,gfc_get_extern_function_decl, + create_function_arglist): Ditto. + * trans-expr.c (gfc_conv_variable,gfc_conv_function_val, + gfc_conv_function_call,gfc_trans_pointer_assignment): Ditto. + + 2008-07-02 Thomas Koenig + + PR fortran/36590 + PR fortran/36681 + * iresolve.c (resolve_mask_arg): Don't convert mask to + kind=1 logical if it is of that type already. + + 2008-06-29 Thomas Koenig + + PR fortran/36341 + * iresolve.c (gfc_resolve_matmul): Copy shapes + from arguments. + + 2008-06-29 Jerry DeLisle + + * invoke.texi: Add documentation for runtime behavior of + -fno-range-check. + + 2008-06-28 Daniel Kraft + + * gfc-internals.texi (section gfc_code): Extended documentation about + gfc_code in the internal datastructures chapter including details about + how IF, DO and SELECT blocks look like and an example for how the + block-chaining works. + + 2008-06-25 Paul Thomas + + PR fortran/36526 + * interface.c (check_intents): Correct error where the actual + arg was checked for a pointer argument, rather than the formal. + + 2008-06-24 Paul Thomas + + PR fortran/34371 + * expr.c (gfc_check_assign): Change message and locus for + error when conform == 0. + + 2008-06-23 Jakub Jelinek + + PR fortran/36597 + * cpp.c (cpp_define_builtins): Change _OPENMP value to 200805. + + 2008-06-20 Laurynas Biveinis + Tobias Burnus + + PR fortran/34908 + PR fortran/36276 + * scanner.c (preprocessor_line): do not call gfc_free for + current_file->filename if it differs from filename. + + 2008-06-20 Kaveh R. Ghazi + + * arith.c (hollerith2representation): Fix for -Wc++-compat. + * array.c (gfc_get_constructor): Likewise. + * decl.c (gfc_get_data_variable, gfc_get_data_value, gfc_get_data, + create_enum_history, gfc_match_final_decl): Likewise. + * error.c (error_char): Likewise. + * expr.c (gfc_get_expr, gfc_copy_expr): Likewise. + * gfortran.h (gfc_get_charlen, gfc_get_array_spec, + gfc_get_component, gfc_get_formal_arglist, gfc_get_actual_arglist, + gfc_get_namelist, gfc_get_omp_clauses, gfc_get_interface, + gfc_get_common_head, gfc_get_dt_list, gfc_get_array_ref, + gfc_get_ref, gfc_get_equiv, gfc_get_case, gfc_get_iterator, + gfc_get_alloc, gfc_get_wide_string): Likewise. + * interface.c (count_types_test): Likewise. + * intrinsic.c (add_char_conversions, gfc_intrinsic_init_1): + Likewise. + * io.c (gfc_match_open, gfc_match_close, match_filepos, match_io, + gfc_match_inquire, gfc_match_wait): Likewise. + * match.c (gfc_match, match_forall_iterator): Likewise. + * module.c (gfc_get_pointer_info, gfc_get_use_rename, add_fixup, + add_true_name, parse_string, write_atom, quote_string, + mio_symtree_ref, mio_gmp_real, write_common_0): Likewise. + * options.c (gfc_post_options): Likewise. + * primary.c (match_integer_constant, match_hollerith_constant, + match_boz_constant, match_real_constant, + gfc_get_structure_ctor_component, gfc_match_structure_constructor): Likewise. + * scanner.c (gfc_widechar_to_char, add_path_to_list, + add_file_change, load_line, get_file, preprocessor_line, + load_file, unescape_filename, gfc_read_orig_filename): Likewise. + * simplify.c (gfc_simplify_ibits, gfc_simplify_ishft, + gfc_simplify_ishftc): Likewise. + * symbol.c (gfc_get_st_label, gfc_get_namespace, gfc_new_symtree, + gfc_get_uop, gfc_new_symbol, save_symbol_data, gfc_get_gsymbol): + Likewise. + * target-memory.c (gfc_target_interpret_expr): Likewise. + * trans-const.c (gfc_build_wide_string_const): Likewise. + * trans-expr.c (gfc_add_interface_mapping): Likewise. + * trans-intrinsic.c (gfc_conv_intrinsic_conversion, + gfc_conv_intrinsic_int, gfc_conv_intrinsic_lib_function, + gfc_conv_intrinsic_cmplx, gfc_conv_intrinsic_ctime, + gfc_conv_intrinsic_fdate, gfc_conv_intrinsic_ttynam, + gfc_conv_intrinsic_minmax, gfc_conv_intrinsic_minmax_char, + gfc_conv_intrinsic_ishftc, gfc_conv_intrinsic_index_scan_verify, + gfc_conv_intrinsic_merge, gfc_conv_intrinsic_trim): Likewise. + * trans.c (gfc_get_backend_locus): Likewise. + * trans.h (gfc_get_ss): Likewise. + + 2008-06-18 Daniel Kraft + + PR fortran/36517, fortran/36492 + * array.c (gfc_resolve_character_array_constructor): Call + gfc_set_constant_character_len with changed length-chec argument. + * decl.c (gfc_set_constant_character_len): Changed array argument to + be a generic length-checking argument that can be used for correct + checking with typespec and in special cases where the should-be length + is different from the target length. + (build_struct): Call gfc_set_constant_character_len with changed length + checking argument and introduced additional checks for exceptional + conditions on invalid code. + (add_init_expr_to_sym), (do_parm): Call gfc_set_constant_character_len + with changed argument. + * match.h (gfc_set_constant_character_len): Changed third argument to + int for the should-be length rather than bool. + + 2008-06-17 Daniel Kraft + + PR fortran/36112 + * array.c (gfc_resolve_character_array_constructor): Check that all + elements with constant character length have the same one rather than + fixing it if no typespec is given, emit an error if they don't. Changed + return type to "try" and return FAILURE for the case above. + (gfc_resolve_array_constructor): Removed unneeded call to + gfc_resolve_character_array_constructor in this function. + * gfortran.h (gfc_resolve_character_array_constructor): Returns try. + * trans-array.c (get_array_ctor_strlen): Return length of first element + rather than last element. + * resolve.c (gfc_resolve_expr): Handle FAILURE return from + gfc_resolve_character_array_constructor. + + 2008-06-17 Paul Thomas + + PR fortran/34396 + * resolve.c (add_dt_to_dt_list): New function. + (resolve_fl_derived): Call new function for pointer components + and when derived type resolved. + + 2008-06-15 Jerry DeLisle + + PR fortran/36515 + * trans-decl.c (gfc_generate_function_code): Add range_check to options + array. + + 2008-06-15 Ralf Wildenhues + + * gfc-internals.texi: Expand TABs, drop indentation outside examples. + * gfortran.texi: Likewise. + * intrinsic.texi: Likewise. + * invoke.texi: Likewise. + + 2008-06-13 Jerry DeLisle + + PR fortran/35863 + * trans-io.c (gfc_build_io_library_fndecls): Build declaration for + transfer_character_wide which includes passing in the character kind to + support wide character IO. (transfer_expr): If the kind == 4, create the + argument and build the call. + * gfortran.texi: Fix typo. + + 2008-06-13 Tobias Burnus + + PR fortran/36476 + * decl.c (do_parm): Handle init expression for len=*. + + 2008-06-12 Tobias Burnus + + PR fortran/36462 + * trans-intrinsic.c (gfc_conv_intrinsic_index_scan_verify): + Fix passing of the BACK= argument. + + 2008-06-10 Jerry DeLisle + + * cpp.c: Add copyright notice. + * cpp.h: Add copyright notice. + + 2008-06-08 Janus Weil + + PR fortran/36459 + * decl.c (match_procedure_decl): Correctly recognize if the interface + is an intrinsic procedure. + + 2008-06-08 Tobias Burnus + + PR fortran/35830 + * resolve.c (resolve_symbol): Copy more attributes for + PROCEDUREs with interfaces. + + 2008-06-07 Jerry DeLisle + + PR fortran/36420 + PR fortran/36422 + * io.c (check_format): Add new error message for zero width. + Use new error message for FMT_A and with READ, FMT_G. Allow + FMT_G with WRITE except when -std=F95 and -std=F2003. + + 2008-06-07 Tobias Burnus + + PR fortran/36437 + * intrinsic.c (add_functions): Implement c_sizeof. + * trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Do not + create unneeded variable in the scalar case. + * intrinsic.texi: Add C_SIZEOF documentation. + + 2008-06-06 Tobias Burnus + + * intrinsic.texi (BESSEL_J1): Fix BES(S)EL_J1 typo. + + 2008-06-06 Jakub Jelinek + + * scanner.c (skip_free_comments, skip_fixed_comments): Handle tabs. + * parse.c (next_free): Allow tab after !$omp. + (decode_omp_directive): Handle !$omp task, !$omp taskwait + and !$omp end task. + (case_executable): Add ST_OMP_TASKWAIT. + (case_exec_markers): Add ST_OMP_TASK. + (gfc_ascii_statement): Handle ST_OMP_TASK, ST_OMP_END_TASK and + ST_OMP_TASKWAIT. + (parse_omp_structured_block, parse_executable): Handle ST_OMP_TASK. + * gfortran.h (gfc_find_sym_in_expr): New prototype. + (gfc_statement): Add ST_OMP_TASK, ST_OMP_END_TASK and ST_OMP_TASKWAIT. + (gfc_omp_clauses): Add OMP_SCHED_AUTO to sched_kind, + OMP_DEFAULT_FIRSTPRIVATE to default_sharing. Add collapse and + untied fields. + (gfc_exec_op): Add EXEC_OMP_TASK and EXEC_OMP_TASKWAIT. + * f95-lang.c (LANG_HOOKS_OMP_CLAUSE_COPY_CTOR, + LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP, LANG_HOOKS_OMP_CLAUSE_DTOR, + LANG_HOOKS_OMP_PRIVATE_OUTER_REF): Define. + * trans.h (gfc_omp_clause_default_ctor): Add another argument. + (gfc_omp_clause_copy_ctor, gfc_omp_clause_assign_op, + gfc_omp_clause_dtor, gfc_omp_private_outer_ref): New prototypes. + * types.def (BT_ULONGLONG, BT_PTR_ULONGLONG, + BT_FN_BOOL_ULONGLONGPTR_ULONGLONGPTR, + BT_FN_BOOL_BOOL_ULL_ULL_ULL_ULLPTR_ULLPTR, + BT_FN_BOOL_BOOL_ULL_ULL_ULL_ULL_ULLPTR_ULLPTR, + BT_FN_VOID_PTR_PTR, BT_PTR_FN_VOID_PTR_PTR, + BT_FN_VOID_OMPFN_PTR_OMPCPYFN_LONG_LONG_BOOL_UINT): New. + (BT_BOOL): Use integer type with BOOL_TYPE_SIZE rather + than boolean_type_node. + * dump-parse-tree.c (gfc_show_omp_node): Handle EXEC_OMP_TASK, + EXEC_OMP_TASKWAIT, OMP_SCHED_AUTO, OMP_DEFAULT_FIRSTPRIVATE, + untied and collapse clauses. + (gfc_show_code_node): Handle EXEC_OMP_TASK and EXEC_OMP_TASKWAIT. + * trans.c (gfc_trans_code): Handle EXEC_OMP_TASK and + EXEC_OMP_TASKWAIT. + * st.c (gfc_free_statement): Likewise. + * resolve.c (gfc_resolve_blocks, resolve_code): Likewise. + (find_sym_in_expr): Rename to... + (gfc_find_sym_in_expr): ... this. No longer static. + (resolve_allocate_expr, resolve_ordinary_assign): Adjust caller. + * match.h (gfc_match_omp_task, gfc_match_omp_taskwait): New + prototypes. + * openmp.c (resolve_omp_clauses): Allow allocatable arrays in + firstprivate, lastprivate, reduction, copyprivate and copyin + clauses. + (omp_current_do_code): Made static. + (omp_current_do_collapse): New variable. + (gfc_resolve_omp_do_blocks): Compute omp_current_do_collapse, + clear omp_current_do_code and omp_current_do_collapse on return. + (gfc_resolve_do_iterator): Handle collapsed do loops. + (resolve_omp_do): Likewise, diagnose errorneous collapsed do loops. + (OMP_CLAUSE_COLLAPSE, OMP_CLAUSE_UNTIED): Define. + (gfc_match_omp_clauses): Handle default (firstprivate), + schedule (auto), untied and collapse (n) clauses. + (OMP_DO_CLAUSES): Add OMP_CLAUSE_COLLAPSE. + (OMP_TASK_CLAUSES): Define. + (gfc_match_omp_task, gfc_match_omp_taskwait): New functions. + * trans-openmp.c (gfc_omp_private_outer_ref): New function. + (gfc_omp_clause_default_ctor): Add outer argument. For allocatable + arrays allocate them with the bounds of the outer var if outer + var is allocated. + (gfc_omp_clause_copy_ctor, gfc_omp_clause_assign_op, + gfc_omp_clause_dtor): New functions. + (gfc_trans_omp_array_reduction): If decl is allocatable array, + allocate it with outer var's bounds in OMP_CLAUSE_REDUCTION_INIT + and deallocate it in OMP_CLAUSE_REDUCTION_MERGE. + (gfc_omp_predetermined_sharing): Return OMP_CLAUSE_DEFAULT_SHARED + for assumed-size arrays. + (gfc_trans_omp_do): Add par_clauses argument. If dovar is + present in lastprivate clause and do loop isn't simple, + set OMP_CLAUSE_LASTPRIVATE_STMT. If dovar is present in + parallel's lastprivate clause, change it to shared and add + lastprivate clause to OMP_FOR_CLAUSES. Handle collapsed do loops. + (gfc_trans_omp_directive): Adjust gfc_trans_omp_do callers. + (gfc_trans_omp_parallel_do): Likewise. Move collapse clause to + OMP_FOR from OMP_PARALLEL. + (gfc_trans_omp_clauses): Handle OMP_SCHED_AUTO, + OMP_DEFAULT_FIRSTPRIVATE, untied and collapse clauses. + (gfc_trans_omp_task, gfc_trans_omp_taskwait): New functions. + (gfc_trans_omp_directive): Handle EXEC_OMP_TASK and + EXEC_OMP_TASKWAIT. + + 2008-06-04 Janus Weil + + PR fortran/36322 + PR fortran/36275 + * resolve.c (resolve_symbol): Correctly copy the interface for a + PROCEDURE declaration. + + 2008-06-02 Janus Weil + + PR fortran/36361 + * symbol.c (gfc_add_allocatable,gfc_add_dimension, + gfc_add_explicit_interface): Added checks. + * decl.c (attr_decl1): Added missing "var_locus". + * parse.c (parse_interface): Checking for errors. + + 2008-06-02 Daniel Kraft + + * gfortran.h: New statement-type ST_FINAL for FINAL declarations. + (struct gfc_symbol): New member f2k_derived. + (struct gfc_namespace): New member finalizers, for use in the above + mentioned f2k_derived namespace. + (struct gfc_finalizer): New type defined for finalizers linked list. + * match.h (gfc_match_final_decl): New function header. + * decl.c (gfc_match_derived_decl): Create f2k_derived namespace on + constructed symbol node. + (gfc_match_final_decl): New function to match a FINAL declaration line. + * parse.c (decode_statement): match-call for keyword FINAL. + (parse_derived): Parse CONTAINS section and accept FINAL statements. + * resolve.c (gfc_resolve_finalizers): New function to resolve (that is + in this case, check) a list of finalizer procedures. + (resolve_fl_derived): Call gfc_resolve_finalizers here. + * symbol.c (gfc_get_namespace): Initialize new finalizers to NULL. + (gfc_free_namespace): Free finalizers list. + (gfc_new_symbol): Initialize new f2k_derived to NULL. + (gfc_free_symbol): Free f2k_derived namespace. + (gfc_free_finalizer): New function to free a single gfc_finalizer node. + (gfc_free_finalizer_list): New function to free a linked list of + gfc_finalizer nodes. + + 2008-06-02 Daniel Franke + + PR fortran/36375 + PR fortran/36377 + * cpp.c (gfc_cpp_init): Do not initialize builtins if + processing already preprocessed input. + (gfc_cpp_preprocess): Finalize output with newline. + + 2008-05-31 Jerry DeLisle + + * intrinsic.texi: Revert wrong commit. + + 2008-05-31 Steven G. Kargl + + * arith.c (gfc_arith_init_1): Remove now unused r and c variables. + Cleanup numerical inquiry function initialization. + (gfc_arith_done_1): Replace multiple mpfr_clear() invocations with + a single mpfr_clears(). + (gfc_check_real_range): Re-arrange logic to eliminate multiple + unnecessary branching and assignments. + (gfc_arith_times): Use mpfr_clears() in preference to multiple + mpfr_clear(). + (gfc_arith_divide): Ditto. + (complex_reciprocal): Eliminate now unused variables a, re, im. + Cleanup the mpfr abuse. Use mpfr_clears() in preference to + multiple mpfr_clear(). + (complex_pow): Fix comment whitespace. Use mpfr_clears() in + preference to multiple mpfr_clear(). + * simplify.c (gfc_simplify_and): Remove blank line. + (gfc_simplify_atan2): Move error checking earlier to eliminate + a now unnecessay gfc_free_expr(). + (gfc_simplify_bessel_j0): Remove unnecessary gfc_set_model_kind(). + (gfc_simplify_bessel_j1): Ditto. + (gfc_simplify_bessel_jn): Ditto. + (gfc_simplify_bessel_y0): Ditto. + (gfc_simplify_bessel_y1): Ditto. + (gfc_simplify_bessel_yn): Ditto. + (only_convert_cmplx_boz): Eliminate unnecessary duplicate code, and + combine nested if statement rational expressions. + (gfc_simplify_cos): Use mpfr_clears() in preference to multiple + mpfr_clear(). + (gfc_simplify_exp): Ditto. + (gfc_simplify_fraction): Move gfc_set_model_kind() to after the + special case of 0. Use mpfr_clears() in preference to multiple + mpfr_clear(). + (gfc_simplify_gamma): Eliminate unnecessary gfc_set_model_kind(). + (gfc_simplify_lgamma): Ditto. + (gfc_simplify_log10): Ditto. + (gfc_simplify_log): Move gfc_set_model_kind () inside switch + statement. Use mpfr_clears() in preference to multiple mpfr_clear(). + (gfc_simplify_mod): Eliminate now unused variables quot, iquot, + and term. Simplify the mpfr magic. + (gfc_simplify_modulo): Ditto. + (gfc_simplify_nearest): Eliminate unnecessary gfc_set_model_kind(). + (gfc_simplify_scale): Use mpfr_clears() in preference to multiple + mpfr_clear(). + (gfc_simplify_sin): Ditto + (gfc_simplify_sqrt): Ditto + (gfc_simplify_set_exponent): Move gfc_set_model_kind() to after the + special case of 0. Use mpfr_clears() in preference to multiple + mpfr_clear(). + + 2008-05-29 Daniel Franke + + PR target/36348 + * Make-lang.in (F95_OBJS): Added dependency on FORTRAN_TARGET_OBJS. + + 2008-05-29 Francois-Xavier Coudert + + * scanner.c (load_line): Add first_char argument. Don't call ungetc. + (gfc_read_orig_filename): Adjust call to load_line. Don't call + ungetc. + (load_file): Adjust call to load_line. + + 2008-05-28 Janus Weil + + PR fortran/36325 + PR fortran/35830 + * interface.c (gfc_procedure_use): Enable argument checking for + external procedures with explicit interface. + * symbol.c (check_conflict): Fix conflict checking for externals. + (copy_formal_args): Fix handling of arrays. + * resolve.c (resolve_specific_f0, resolve_specific_s0): Fix handling + of intrinsics. + * parse.c (parse_interface): Non-abstract INTERFACE statement implies + EXTERNAL attribute. + + 2008-05-28 Francois-Xavier Coudert + + PR fortran/36319 + * intrinsic.c (gfc_convert_chartype): Don't mark conversion + function as pure. + * trans-array.c (gfc_trans_array_ctor_element): Divide element + size by the size of one character to obtain length. + * iresolve.c (gfc_resolve_cshift): Call the _char4 variant when + appropriate. + (gfc_resolve_eoshift): Likewise. + * trans-intrinsic.c (gfc_conv_intrinsic_ctime): Minor beautification. + (gfc_conv_intrinsic_fdate): Minor beautification. + (gfc_conv_intrinsic_ttynam): Minor beautification. + (gfc_conv_intrinsic_minmax_char): Allow all character kinds. + (size_of_string_in_bytes): New function. + (gfc_conv_intrinsic_size): Call size_of_string_in_bytes for + character expressions. + (gfc_conv_intrinsic_sizeof): Likewise. + (gfc_conv_intrinsic_array_transfer): Likewise. + (gfc_conv_intrinsic_trim): Allow all character kinds. Minor + beautification. + (gfc_conv_intrinsic_repeat): Fix comment typo. + * simplify.c (gfc_convert_char_constant): Take care of conversion + of array constructors. + + 2008-05-27 Tobias Burnus + + PR fortran/36316 + * trans-array.c (gfc_set_loop_bounds_from_array_spec): + Add missing fold_convert. + + 2008-05-26 Daniel Franke + + * fortran/cpp.c (cpp_define_builtins): Remove usage of TARGET_* macros, + added FIXME instead. + + 2008-05-26 Daniel Franke + + PR fortran/18428 + * lang.opt (A, C, CC, D, E, H, P, U, cpp, d, fworking-directory, + imultilib, iprefix, iquote, isysroot, isystem, nocpp, nostdinc, + o, undef, v): New options. + * options.c (gfc_init_options): Also initialize preprocessor + options. + (gfc_post_options): Also handle post-initialization of preprocessor + options. + (gfc_handle_option): Check if option is a preprocessor option. + If yes, let gfc_cpp_handle_option() handle the option. + * lang-specs.h: Reorganized to handle new options. + * scanner.c (gfc_new_file): Read temporary file instead of + input source if preprocessing is enabled. + * f95-lang.c (gfc_init): Initialize preprocessor. + (gfc_finish): Clean up preprocessor. + * cpp.c: New. + * cpp.h: New. + * Make-lang.in: Added new objects and dependencies. + * gfortran.texi: Updated section "Preprocessing and + conditional compilation". + * invoke.texi: Added new section "Preprocessing Options", + listed and documented the preprocessing options handled + by gfortran. + + 2008-05-25 Tobias Burnus + + PR fortran/32600 + * trans-expr.c (gfc_conv_function_call): Remove library + call for c_f_pointer with scalar Fortran pointers and for + c_f_procpointer. + + 2008-05-21 Francois-Xavier Coudert + + PR fortran/36257 + * iresolve.c (check_charlen_present): Don't force the rank to 1. + + 2008-05-19 Francois-Xavier Coudert + + PR fortran/36265 + * trans-expr.c (gfc_conv_string_tmp): Pick the correct type for + the temporary variable. + + 2008-05-19 Francois-Xavier Coudert + + * simplify.c (gfc_simplify_dble, gfc_simplify_real): Initialize + result variable to avoid warnings. + + 2008-05-18 Francois-Xavier Coudert + + * intrinsic.c (char_conversions, ncharconv): New static variables. + (find_char_conv): New function. + (add_functions): Add simplification functions for ADJUSTL and + ADJUSTR. Don't check the kind of their argument. Add checking for + LGE, LLE, LGT and LLT. + (add_subroutines): Fix argument type for SLEEP. Fix argument name + for SYSTEM. + (add_char_conversions): New function. + (gfc_intrinsic_init_1): Call add_char_conversions. + (gfc_intrinsic_done_1): Free char_conversions. + (check_arglist): Use kind == 0 as a signal that we don't want + the kind value to be checked. + (do_simplify): Also simplify character functions. + (gfc_convert_chartype): New function + * trans-array.c (gfc_trans_array_ctor_element): Don't force the + use of default character type. + (gfc_trans_array_constructor_value): Likewise. + (get_array_ctor_var_strlen): Use integer kind to build an integer + instead of a character kind! + (gfc_build_constant_array_constructor): Don't force the use of + default character type. + (gfc_conv_loop_setup): Likewise. + * trans-expr.c (gfc_conv_string_tmp): Don't force the use of + default character type. Allocate enough memory for wide strings. + (gfc_conv_concat_op): Make sure operand kind are the same. + (string_to_single_character): Remove gfc_ prefix. Reindent. + Don't force the use of default character type. + (gfc_conv_scalar_char_value): Likewise. + (gfc_build_compare_string): Call string_to_single_character. + (fill_with_spaces): New function + (gfc_trans_string_copy): Add kind arguments. Use them to deal + with wide character kinds. + (gfc_conv_statement_function): Whitespace fix. Call + gfc_trans_string_copy with new kind arguments. + (gfc_conv_substring_expr): Call gfc_build_wide_string_const + instead of using gfc_widechar_to_char. + (gfc_conv_string_parameter): Don't force the use of default + character type. + (gfc_trans_scalar_assign): Pass kind args to gfc_trans_string_copy. + * intrinsic.h (gfc_check_lge_lgt_lle_llt, gfc_convert_char_constant, + gfc_resolve_adjustl, gfc_resolve_adjustr): New prototypes. + * decl.c (gfc_set_constant_character_len): Don't assert the + existence of a single character kind. + * trans-array.h (gfc_trans_string_copy): New prototype. + * gfortran.h (gfc_check_character_range, gfc_convert_chartype): + New prototypes. + * error.c (print_wide_char_into_buffer): New function lifting + code from gfc_print_wide_char. Fix order to output '\x??' instead + of 'x\??'. + (gfc_print_wide_char): Call print_wide_char_into_buffer. + (show_locus): Call print_wide_char_into_buffer with buffer local + to this function. + * trans-const.c (gfc_build_wide_string_const): New function. + (gfc_conv_string_init): Deal with wide characters strings + constructors. + (gfc_conv_constant_to_tree): Call gfc_build_wide_string_const. + * trans-stmt.c (gfc_trans_label_assign): Likewise. + (gfc_trans_character_select): Deal with wide strings. + * expr.c (gfc_check_assign): Allow conversion between character + kinds on assignment. + * trans-const.h (gfc_build_wide_string_const): New prototype. + * trans-types.c (gfc_get_character_type_len_for_eltype, + gfc_get_character_type_len): Create too variants of the old + gfc_get_character_type_len, one getting kind argument and the + other one directly taking a type tree. + * trans.h (gfor_fndecl_select_string_char4, + gfor_fndecl_convert_char1_to_char4, + gfor_fndecl_convert_char4_to_char1): New prototypes. + * trans-types.h (gfc_get_character_type_len_for_eltype): New + prototype. + * resolve.c (resolve_operator): Exit early when kind mismatches + are detected, because that makes us issue an error message later. + (validate_case_label_expr): Fix wording of error message. + * iresolve.c (gfc_resolve_adjustl, gfc_resolve_adjustr): New + functions. + (gfc_resolve_pack): Call _char4 variants of library function + when dealing with wide characters. + (gfc_resolve_reshape): Likewise. + (gfc_resolve_spread): Likewise. + (gfc_resolve_transpose): Likewise. + (gfc_resolve_unpack): Likewise. + * target-memory.c (size_character): Take character kind bit size + correctly into account (not that it changes anything for now, but + it's more generic). + (gfc_encode_character): Added gfc_ prefix. Encoding each + character of a string by calling native_encode_expr for the + corresponding unsigned integer. + (gfc_target_encode_expr): Add gfc_ prefix to encode_character. + * trans-decl.c (gfc_build_intrinsic_function_decls): Build + gfor_fndecl_select_string_char4, gfor_fndecl_convert_char1_to_char4 + and gfor_fndecl_convert_char4_to_char1. + * target-memory.h (gfc_encode_character): New prototype. + * arith.c (gfc_check_character_range): New function. + (eval_intrinsic): Allow non-default character kinds. + * check.c (gfc_check_access_func): Only allow default + character kind arguments. + (gfc_check_chdir): Likewise. + (gfc_check_chdir_sub): Likewise. + (gfc_check_chmod): Likewise. + (gfc_check_chmod_sub): Likewise. + (gfc_check_lge_lgt_lle_llt): New function. + (gfc_check_link): Likewise. + (gfc_check_link_sub): Likewise. + (gfc_check_symlnk): Likewise. + (gfc_check_symlnk_sub): Likewise. + (gfc_check_rename): Likewise. + (gfc_check_rename_sub): Likewise. + (gfc_check_fgetputc_sub): Likewise. + (gfc_check_fgetput_sub): Likewise. + (gfc_check_stat): Likewise. + (gfc_check_stat_sub): Likewise. + (gfc_check_date_and_time): Likewise. + (gfc_check_ctime_sub): Likewise. + (gfc_check_fdate_sub): Likewise. + (gfc_check_gerror): Likewise. + (gfc_check_getcwd_sub): Likewise. + (gfc_check_getarg): Likewise. + (gfc_check_getlog): Likewise. + (gfc_check_hostnm): Likewise. + (gfc_check_hostnm_sub): Likewise. + (gfc_check_ttynam_sub): Likewise. + (gfc_check_perror): Likewise. + (gfc_check_unlink): Likewise. + (gfc_check_unlink_sub): Likewise. + (gfc_check_system_sub): Likewise. + * primary.c (got_delim): Perform correct character range checking + for all kinds. + * trans-intrinsic.c (gfc_conv_intrinsic_conversion): Generate + calls to library functions convert_char4_to_char1 and + convert_char1_to_char4 for character conversions. + (gfc_conv_intrinsic_char): Allow all character kings. + (gfc_conv_intrinsic_strcmp): Fix whitespace. + (gfc_conv_intrinsic_repeat): Take care of all character kinds. + * intrinsic.texi: For all GNU intrinsics accepting character + arguments, mention that they're restricted to the default kind. + * simplify.c (simplify_achar_char): New function. + (gfc_simplify_achar, gfc_simplify_char): Call simplify_achar_char. + gfc_simplify_ichar): Don't error out for wide characters. + (gfc_convert_char_constant): New function. + + 2008-05-18 Steven G. Kargl + + PR fortran/36251 + * symbol.c (check_conflict): Issue errors for abuse of PUBLIC, PRIVATE, + and BIND(C). + * resolve.c (gfc_verify_binding_labels): Fix NULL pointer dereference. + + 2008-05-17 Tobias Burnus + + * intrinsic.texi: Correct description of GET_COMMAND_ARGUMENT + and GET_ENVIRONMENT_VARIABLE; fix keyword= name for GETENV, + GETLOG, GMTIME, HOSTNM, IRAND, ITIME, KILL. + Move LOG_GAMMA after LOG10. + + 2008-05-17 Tobias Burnus + + * intrinsic.c (add_functions): Change FLUSH(C) to FLUSH(UNIT). + * intrinsic.texi: Change INTEGER(*) to INTEGER; fix keyword= name for + ABS, ADJUSTL, AINT, ALLOCATED, ANINT, ASSOCIATED, C_ASSOCIATED, + CEILING, DBLE, DFLOAT, DOT_PRODUCT, DREAL, FLOAT, FLOOR, GET_COMMAND. + + 2008-05-16 Paul Thomas + + PR fortran/35756 + PR fortran/35759 + * trans-stmt.c (gfc_trans_where): Tighten up the dependency + check for calling gfc_trans_where_3. + + PR fortran/35743 + * trans-stmt.c (gfc_trans_where_2): Set the mask size to zero + if it is calculated to be negative. + + PR fortran/35745 + * trans-stmt.c (gfc_trans_where_3, gfc_trans_where_assign): Set + ss->where for scalar right hand sides. + * trans-array.c (gfc_add_loop_ss_code): If ss->where is set do + not evaluate scalars outside the loop. Clean up whitespace. + * trans.h : Add a bitfield 'where' to gfc_ss. + + 2008-05-16 Tobias Burnus + + * libgfortran.h: Increase GFC_MAX_DIMENSIONS to 15. + * array.c (gfc_match_array_spec): Error with -std=f2003 if rank > 7. + + 2008-04-16 Daniel Kraft + + PR fortran/27997 + * gfortran.h: Added field "length_from_typespec" to gfc_charlength. + * aray.c (gfc_match_array_constructor): Added code to parse typespec. + (check_element_type, check_constructor_type, gfc_check_constructor_type): + Extended to support explicit typespec on constructor. + (gfc_resolve_character_array_constructor): Pad strings correctly for + explicit, constant character length. + * trans-array.c: New static global variable "typespec_chararray_ctor" + (gfc_trans_array_constructor): New code to support explicit but dynamic + character lengths. + + 2008-05-16 Jerry DeLisle + + PR fortran/34325 + * decl.c (match_attr_spec): Check for matching pairs of parenthesis. + * expr.c (gfc_specification_expr): Supplement the error message with the + type that was found. + * resolve.c (gfc_resolve_index): Likewise. + * match.c (gfc_match_parens): Clarify error message with "at or before". + (gfc_match_do): Check for matching pairs of parenthesis. + + 2008-05-16 Tobias Burnus + + * primary.c: New private structure "gfc_structure_ctor_component". + (gfc_free_structure_ctor_component): New helper function. + (gfc_match_structure_constructor): Extended largely to support named + arguments and default initialization for structure constructors. + + 2008-05-15 Steven G. Kargl + + * simplify.c (gfc_simplify_dble, gfc_simplify_float, + simplify_bound, gfc_simplify_nearest, gfc_simplify_real): Plug + possible memory leaks. + (gfc_simplify_reshape): Plug possible memory leaks and dereferencing + of NULL pointers. + + 2008-05-15 Steven G. Kargl + + PR fortran/36239 + * simplify.c (gfc_simplify_int, gfc_simplify_intconv): Replaced hand + rolled integer conversion with gfc_int2int, gfc_real2int, and + gfc_complex2int. + (gfc_simplify_intconv): Renamed to simplify_intconv. + + 2008-05-15 Steven G. Kargl, + * gfortran.dg/and_or_xor.f90: New test + + * fortran/simplify.c (gfc_simplify_and, gfc_simplify_or, + gfc_simplify_xor): Don't range check logical results. + + 2008-05-15 Francois-Xavier Coudert + + * trans-expr.c (gfc_conv_concat_op): Take care of nondefault + character kinds. + (gfc_build_compare_string): Add kind argument and use it. + (gfc_conv_statement_function): Fix indentation. + * gfortran.h (gfc_character_info): New structure. + (gfc_character_kinds): New array. + * trans-types.c (gfc_character_kinds, gfc_character_types, + gfc_pcharacter_types): New array. + (gfc_init_kinds): Fill character kinds array. + (validate_character): Take care of nondefault character kinds. + (gfc_build_uint_type): New function. + (gfc_init_types): Take care of nondefault character kinds. + (gfc_get_char_type, gfc_get_pchar_type): New functions. + (gfc_get_character_type_len): Use gfc_get_char_type. + * trans.h (gfc_build_compare_string): Adjust prototype. + (gfor_fndecl_compare_string_char4, gfor_fndecl_concat_string_char4, + gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4, + gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4, + gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4, + gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4): New + prototypes. + * trans-types.h (gfc_get_char_type, gfc_get_pchar_type): New + prototypes. + * trans-decl.c (gfor_fndecl_compare_string_char4, + gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4, + gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4, + gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4, + gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4, + gfor_fndecl_concat_string_char4): New function decls. + (gfc_build_intrinsic_function_decls): Define new *_char4 function + decls. + * trans-intrinsic.c (gfc_conv_intrinsic_minmax_char, + gfc_conv_intrinsic_len_trim, gfc_conv_intrinsic_ichar, + gfc_conv_intrinsic_strcmp, gfc_conv_intrinsic_trim, + gfc_conv_intrinsic_function): Deal with nondefault character kinds. + + 2008-05-15 Sa Liu + + * iso-c-binding.def: Add standard parameter to macro NAMED_INTCST. + All existing NAMED_INTCST definitions has standard GFC_STD_F2003, + c_int128_t, c_int_least128_t and c_int_fast128_t are added as + GNU extensions. + * iso-fortran-evn.def: Add standard parameter GFC_STD_F2003 + to macro NAMED_INTCST. + * symbol.c (std_for_isocbinding_symbol): New helper function to + return the standard that supports this isocbinding symbol. + (generate_isocbinding_symbol): Do not generate GNU extension symbols + if std=f2003. Add new parameter to NAMED_INTCST. + * module.c (use_iso_fortran_env_module): Add new parameter to + NAMED_INTCST and new field standard to struct intmod_sym. + * gfortran.h: Add new parameter to NAMED_INTCST. + * trans-types.c (init_c_interop_kinds): Add new parameter to + NAMED_INTCST. + * intrinsic.texi: Documented new types C_INT128_T, C_INT_LEASE128_T + and C_INT_FAST128_T. + + 2008-05-14 Francois-Xavier Coudert + + PR fortran/36059 + * trans-decl.c (gfc_build_dummy_array_decl): Don't repack + arrays that have the TARGET attribute. + + 2008-05-14 Francois-Xavier Coudert + + PR fortran/36186 + * simplify.c (only_convert_cmplx_boz): New function. + (gfc_simplify_cmplx, gfc_simplify_complex, gfc_simplify_dcmplx): + Call only_convert_cmplx_boz. + + 2008-05-14 Paul Thomas + + PR fortran/36233 + * interface.c (compare_actual_formal): Do not check sizes if the + actual is BT_PROCEDURE. + + 2008-05-14 Francois-Xavier Coudert + + PR fortran/35682 + * trans-array.c (gfc_conv_ss_startstride): Any negative size is + the same as zero size. + (gfc_conv_loop_setup): Fix size calculation. + + 2008-05-14 Francois-Xavier Coudert + + PR fortran/35685 + * trans-intrinsic.c (gfc_conv_intrinsic_bound): Correctly + handle zero-size sections. + + 2008-05-14 Francois-Xavier Coudert + + PR fortran/36215 + * scanner.c (preprocessor_line): Allocate enough memory for a + wide string. + + 2008-05-12 Francois-Xavier Coudert + + PR fortran/36176 + * target-memory.c (gfc_target_expr_size): Correctly treat + substrings. + (gfc_target_encode_expr): Likewise. + (gfc_interpret_complex): Whitespace change. + + 2008-05-11 Thomas Koenig + + PR fortran/35719 + * trans.c (gfc_call_malloc): If size equals zero, allocate one + byte; don't return a null pointer. + + 2008-05-10 Francois-Xavier Coudert + + PR fortran/36197 + * module.c (quote_string): Fix sprintf format. + + 2008-05-09 Francois-Xavier Coudert + + PR fortran/36162 + * module.c (quote_string, unquote_string, + mio_allocated_wide_string): New functions. + (mio_expr): Call mio_allocated_wide_string where needed. + + 2008-05-07 Kenneth Zadeck + + * trans-decl.c (gfc_get_extern_function_decl, build_function_decl): + Rename DECL_IS_PURE to DECL_PURE_P. + + 2008-05-06 Francois-Xavier Coudert + + * arith.c: (gfc_arith_concat, gfc_compare_string, + gfc_compare_with_Cstring, hollerith2representation, + gfc_hollerith2int, gfc_hollerith2real, gfc_hollerith2complex, + gfc_hollerith2character, gfc_hollerith2logical): Use wide + characters for character constants. + * data.c (create_character_intializer): Likewise. + * decl.c (gfc_set_constant_character_len): Likewise. + * dump-parse-tree.c (show_char_const): Correctly dump wide + character strings. + error.c (print_wide_char): Rename into gfc_print_wide_char. + (show_locus): Adapt to new prototype of gfc_print_wide_char. + expr.c (free_expr0): Representation is now disjunct from + character string value, so we always free it. + (gfc_copy_expr, find_substring_ref, gfc_simplify_expr): Adapt + to wide character strings. + * gfortran.h (gfc_expr): Make value.character.string a wide string. + (gfc_wide_toupper, gfc_wide_strncasecmp, gfc_wide_memset, + gfc_widechar_to_char, gfc_char_to_widechar): New prototypes. + (gfc_get_wide_string): New macro. + (gfc_print_wide_char): New prototype. + * io.c (format_string): Make a wide string. + (next_char, gfc_match_format, compare_to_allowed_values, + gfc_match_open): Deal with wide strings. + * module.c (mio_expr): Convert between wide strings and ASCII ones. + * primary.c (match_hollerith_constant, match_charkind_name): + Handle wide strings. + * resolve.c (build_default_init_expr): Likewise. + * scanner.c (gfc_wide_toupper, gfc_wide_memset, + gfc_char_to_widechar): New functions. + (wide_strchr, gfc_widechar_to_char, gfc_wide_strncasecmp): + Changes in prototypes. + (gfc_define_undef_line, load_line, preprocessor_line, + include_line, load_file, gfc_read_orig_filename): Handle wide + strings. + * simplify.c (gfc_simplify_achar, gfc_simplify_adjustl, + gfc_simplify_adjustr, gfc_simplify_char, gfc_simplify_iachar, + gfc_simplify_ichar, simplify_min_max, gfc_simplify_new_line, + gfc_simplify_repeat): Handle wide strings. + (wide_strspn, wide_strcspn): New helper functions. + (gfc_simplify_scan, gfc_simplify_trim, gfc_simplify_verify): + Handle wide strings. + * symbol.c (generate_isocbinding_symbol): Likewise. + * target-memory.c (size_character, gfc_target_expr_size, + encode_character, gfc_target_encode_expr, gfc_interpret_character, + gfc_target_interpret_expr): Handle wide strings. + * trans-const.c (gfc_conv_string_init): Lower wide strings to + narrow ones. + (gfc_conv_constant_to_tree): Likewise. + * trans-expr.c (gfc_conv_substring_expr): Handle wide strings. + * trans-io.c (gfc_new_nml_name_expr): Likewise. + * trans-stmt.c (gfc_trans_label_assign): Likewise. + + 2008-05-06 Francois-Xavier Coudert + + * simplify.c (gfc_simplify_bessel_j0,gfc_simplify_bessel_j1, + gfc_simplify_bessel_jn,gfc_simplify_bessel_y0, + gfc_simplify_bessel_y1,gfc_simplify_bessel_yn): Mark arguments + with ATTRIBUTE_UNUSED. + + 2008-05-06 Francois-Xavier Coudert + + * check.c (gfc_check_sizeof): Switch to ATTRIBUTE_UNUSED. + * simplify.c (gfc_simplify_lgamma): Likewise. + + 2008-05-06 Francois-Xavier Coudert + + * openmp.c (gfc_match_omp_eos): Use gfc_next_ascii_char and + gfc_peek_ascii_char. + * decl.c (gfc_match_kind_spec, gfc_match_type_spec, + gfc_match_implicit_none, match_implicit_range, gfc_match_implicit, + match_string_p, match_attr_spec, gfc_match_suffix, + match_procedure_decl, gfc_match_entry, gfc_match_subroutine): + Likewise. + * gfortran.h (gfc_char_t): New type. + (gfc_linebuf): Make line member a gfc_char_t. + (locus): Make nextc member a gfc_char_t. + (gfc_wide_is_printable, gfc_wide_is_digit, gfc_wide_fits_in_byte, + gfc_wide_tolower, gfc_wide_strlen, gfc_next_ascii_char, + gfc_peek_ascii_char, gfc_check_digit): New prototypes. + * error.c (print_wide_char): New function. + (show_locus): Use print_wide_char and gfc_wide_strlen. + * io.c (next_char): Use gfc_char_t type. + (match_io): Use gfc_peek_ascii_char and gfc_next_ascii_char. + * match.c (gfc_match_parens, gfc_match_eos, + gfc_match_small_literal_int, gfc_match_name, gfc_match_name_C, + gfc_match_intrinsic_op, gfc_match_char, gfc_match_return, + gfc_match_common): Likewise. + * match.h (gfc_match_special_char): Change prototype. + * parse.c (decode_specification_statement, decode_statement, + decode_omp_directive, next_free, next_fixed): Use + gfc_peek_ascii_char and gfc_next_ascii_char. + * primary.c (gfc_check_digit): Change name. + (match_digits, match_hollerith_constant, match_boz_constant, + match_real_constant, next_string_char, match_charkind_name, + match_string_constant, match_logical_constant_string, + match_complex_constant, match_actual_arg, match_varspec, + gfc_match_rvalue, match_variable): Use gfc_peek_ascii_char and + gfc_next_ascii_char. + * scanner.c (gfc_wide_fits_in_byte, wide_is_ascii, + gfc_wide_is_printable, gfc_wide_tolower, gfc_wide_is_digit, + gfc_wide_is_digit, wide_atoi, gfc_wide_strlen, wide_strcpy, + wide_strchr, widechar_to_char, wide_strncmp, wide_strncasecmp, + gfc_next_ascii_char, gfc_peek_ascii_char): + New functions. + (next_char, gfc_define_undef_line, skip_free_comments, + gfc_next_char_literal, gfc_next_char, gfc_peek_char, + gfc_error_recovery, load_line, preprocessor_line, include_line, + load_file, gfc_read_orig_filename): Use gfc_char_t for source + characters and the {gfc_,}wide_* functions to manipulate wide + strings. + + 2008-05-06 Tobias Burnus + + PR fortran/36117 + * intrinsic.c (add_functions): Call gfc_simplify_bessel_*. + * intrinsic.h: Add prototypes for gfc_simplify_bessel_*. + * simplify.c (gfc_simplify_bessel_j0,gfc_simplify_bessel_j1, + gfc_simplify_bessel_jn,gfc_simplify_bessel_y0, + gfc_simplify_bessel_y1,gfc_simplify_bessel_yn): New. + + 2008-05-03 Janus Weil + + * misc.c (gfc_clear_ts): Set interface to NULL. + + 2008-05-03 Jerry DeLisle + + PR fortran/33268 + * gfortran.h: Add extra_comma pointer to gfc_dt structure. Add iokind to + gfc_expr value union. Add io_kind enum to here from io.c. + * io.c (gfc_free_dt): Free extra_comma. + (gfc_resolve_dt): If an extra comma was encountered and io_unit is type + BT_CHARACTER, resolve to format_expr and set default unit. Error if + io_kind is M_WRITE. (match_io): Match the extra comma and set new + pointer, extra_comma. + + 2008-05-01 Bud Davis + + PR35940/Fortran + * simplify.c (gfc_simplify_index): Check for direction argument + being a constant. + + 2008-05-01 Janus Weil + + * gfortran.h (struct gfc_symbol): Moving "interface" member to + gfc_typespec (plus fixing a small docu error). + * interface.c (gfc_procedure_use): Ditto. + * decl.c (match_procedure_decl): Ditto. + * resolve.c (resolve_specific_f0, + resolve_specific_f0, resolve_symbol): Ditto. + + 2008-04-30 Francois-Xavier Coudert + + * intrinsic.c (add_functions): Add SELECTED_CHAR_KIND intrinsic. + * intrinsic.h (gfc_check_selected_char_kind, + gfc_simplify_selected_char_kind): New prototypes. + * gfortran.h (gfc_isym_id): Add GFC_ISYM_SC_KIND. + * trans.h (gfor_fndecl_sc_kind): New function decl. + * trans-decl.c (gfor_fndecl_sc_kind): Build new decl. + * arith.c (gfc_compare_with_Cstring): New function. + * arith.h (gfc_compare_with_Cstring): New prototype. + * check.c (gfc_check_selected_char_kind): New function. + * primary.c (match_string_constant, match_kind_param): Mark + symbols used as literal constant kind param as referenced. + * trans-intrinsic.c (gfc_conv_intrinsic_sc_kind): New function. + (gfc_conv_intrinsic_function): Call gfc_conv_intrinsic_sc_kind. + * intrinsic.texi (SELECTED_CHAR_KIND): Document new intrinsic. + * simplify.c (gfc_simplify_selected_char_kind): New function. + + 2008-04-28 Paul Thomas + + PR fortran/35997 + * module.c (find_symbol): Do not return a result for a symbol + that has been renamed in another module. + + 2008-04-26 George Helffrich + + PR fortran/35892 + PR fortran/35154 + * trans-common.c (create_common): Add decl to function + chain (if inside one) to preserve identifier scope in debug output. + + 2008-04-25 Jan Hubicka + + * trans-decl.c (trans_function_start): Update. + + 2008-04-25 Tobias Burnus + Daniel Franke + + PR fortran/35156 + * gfortranspec.c (lang_specific_driver): Deprecate + -M option; fix ICE when "-M" is last argument and + make "-M" work. + * options.c (gfc_handle_module_path_options): + Use -J instead of -M in error messages. + * invoke.texi: Mark -M as depecated. + + 2008-04-23 Jerry DeLisle + Francois-Xavier Coudert + + PR fortran/35994 + * trans-instrinsic.c (gfc_conv_intrinsic_minmaxloc): Correctly adjust + loop counter offset. + + 2008-04-23 Paolo Bonzini + + * trans-expr.c (gfc_conv_structure): Don't set TREE_INVARIANT. + * trans-array.c (gfc_build_null_descriptor): Don't set TREE_INVARIANT. + (gfc_trans_array_constructor_value): Don't set TREE_INVARIANT. + (gfc_build_constant_array_constructor): Don't set TREE_INVARIANT. + (gfc_conv_array_initializer): Don't set TREE_INVARIANT. + * trans-common.c (get_init_field): Don't set TREE_INVARIANT. + (create_common): Don't set TREE_INVARIANT. + * trans-stmt.c (gfc_trans_character_select): Don't set TREE_INVARIANT. + * trans-decl.c (gfc_generate_function_code): Don't set TREE_INVARIANT. + + 2008-04-21 Steve Ellcey + + * f95-lang.c (gfc_init_decl_processing): use ptr_mode instead of Pmode. + + 2008-04-21 Daniel Franke + + PR fortran/35019 + * gfortranspec.c (lookup_option): Properly handle separated arguments + in -J option, print missing argument message when necessary. + + 2008-04-20 Jerry DeLisle + + PR fortran/35882 + * scanner.c (skip_fixed_comments): Update continue_line when comment is + detected. (gfc_next_char_literal): Likewise. + + 2008-04-19 Paul Thomas + + PR fortran/35944 + PR fortran/35946 + PR fortran/35947 + * trans_array.c (gfc_trans_array_constructor): Temporarily + realign loop, if loop->from is not zero, before creating + the temporary array and provide an offset. + + PR fortran/35959 + * trans-decl.c (gfc_init_default_dt): Add gfc_ prefix to name + and allow for NULL body. Change all references from + init_default_dt to gfc_init_default_dt. + * trans.h : Add prototype for gfc_init_default_dt. + * trans-array.c (gfc_trans_deferred_vars): After nullification + call gfc_init_default_dt for derived types with allocatable + components. + + 2008-04-18 Jerry DeLisle + + PR fortran/35892 + * trans-common.c (create_common): Revert patch causing regression. + + 2008-04-16 Jerry DeLisle + + PR fortran/35724 + * iresolve.c (gfc_resolve_eoshift): Check for NULL symtree in test for + optional argument attribute. + + 2008-04-16 Paul Thomas + + PR fortran/35932 + * trans-intrinsic.c (gfc_conv_intrinsic_char): Even though KIND + is not used, the argument must be converted. + + 2008-04-16 Jakub Jelinek + + PR target/35662 + * f95-lang.c (gfc_init_builtin_functions): Make sure + BUILT_IN_SINCOS{,F,L} types aren't varargs. + + 2008-04-15 Paul Thomas + + PR fortran/35864 + * expr.c (scalarize_intrinsic_call): Reorder identification of + array argument so that if one is not found a segfault does not + occur. Return FAILURE if all scalar arguments. + + 2008-04-13 Jerry DeLisle + Tobias Burnus + + PR fortran/35882 + * options.c (gfc_init_options): Set the default maximum continuation + lines to 255 for both free and fixed form source for warnings. + (gfc_handle_option): Set -std=f95 fixed form max continuations to 19 and + the -std=f95 free form max continuations to 39 for warnings. + * scanner.c (gfc_next_char_literal): Adjust the current_line number only + if it is less than the current locus. + + 2008-04-07 Jerry DeLisle + + PR fortran/25829 28655 + * io.c (io_tag): Add new tags for decimal, encoding, asynchronous, + round, sign, and id. (match_open_element): Match new tags. + (gfc_resolve_open): Resolve new tags. (gfc_match_open): Enable encoding + for DEFAULT only. Update error messages. (match_dt_element): Fix match + tag for asynchronous. Update error messages. (gfc_free_inquire): Free + new expressions. (match_inquire_element): Match new tags. + (gfc_match_inquire): Add constraint for ID and PENDING. + (gfc_resolve_inquire): Resolve new tags. + * trans-io.c (gfc_trans_inquire): Clean up whitespace and fix setting of + mask for ID parameter. + * ioparm.def: Fix order of parameters for pending, round, and sign. + NOTE: These must line up with the definitions in libgfortran/io/io.h. or + things don't work. + + 2008-04-06 Paul Thomas + + PR fortran/35780 + * expr.c (scalarize_intrinsic_call): Identify which argument is + an array and use that as the template. + (check_init_expr): Remove tests that first argument is an array + in the call to scalarize_intrinsic_call. + + 2008-04-06 Tobias Schlüter + + PR fortran/35832 + * io.c (io_tag): Add field 'value'. Split 'spec' field in + existing io_tags. + (match_etag, match_vtag, match_ltag): Split parsing in two steps + to give better error messages. + + 2008-04-06 Tobias Burnus + + * io.c (check_io_constraints): Add constrains. ID= requires + asynchronous= and asynchronous= must be init expression. + + 2008-04-06 Francois-Xavier Coudert + + * f95-lang.c: Set LANG_HOOKS_NAME to "GNU Fortran". + + 2008-04-06 Francois-Xavier Coudert + + * dump-parse-tree.c: Use fprintf, fputs and fputc instead of + gfc_status and gfc_status_char. Remove gfc_ prefix of the gfc_show_* + functions and make them static. Add new gfc_dump_parse_tree + function. + * gfortran.h (gfc_option_t): Rename verbose into dump_parse_tree. + (gfc_status, gfc_status_char): Delete prototypes. + * error.c (gfc_status, gfc_status_char): Remove functions. + * scanner.c (gfc_new_file): Use printf instead of gfc_status. + * options.c (gfc_init_options): Rename verbose into dump_parse_tree. + (gfc_handle_module_path_options): Use gfc_fatal_error instead of + gfc_status and exit. + (gfc_handle_option): Rename verbose into dump_parse_tree. + * parse.c (gfc_parse_file): Use gfc_dump_parse_tree. + + 2008-04-05 Jerry DeLisle + Francois-Xavier Coudert + + PR fortran/25829 28655 + * dump-parse-tree.c (gfc_show_code_node): Show new I/O parameters. + * gfortran.h (gfc_statement): Add ST_WAIT enumerator. + (gfc_open): Add pointers for decimal, encoding, round, sign, + asynchronous. (gfc_inquire): Add pointers for asynchronous, decimal, + encoding, pending, round, sign, size, id. + (gfc_wait): New typedef struct. (gfc_dt): Add pointers for id, pos, + asynchronous, blank, decimal, delim, pad, round, sign. + (gfc_exec_op): Add EXEC_WAIT enumerator. (gfc_code): Add pointer for + wait. (gfc_free_wait), (gfc_resolve_wait): New function prototypes. + * trans-stmt.h (gfc_trans_wait): New function prototype. + * trans.c (gfc_trans_code): Add case for EXEC_WAIT. + * io.c (io_tag): Add new tags for DECIMAL, ENCODING, ROUND, SIGN, + ASYCHRONOUS, ID. (match_open_element): Add matchers for new tags. + (gfc_free_open): Free new pointers. (gfc_resolve_open): Resolve new + tags. (gfc_resolve_open): Remove comment around check for allowed + values and ASYNCHRONOUS, update it. Likewise for DECIMAL, ENCODING, + ROUND, and SIGN. (match_dt_element): Add matching for new tags. + (gfc_free_wait): New function. (gfc_resolve_wait): New function. + (match_wait_element): New function. (gfc_match_wait): New function. + * resolve.c (gfc_resolve_blocks): Add case for EXEC_WAIT. + (resolve_code): Add case for EXEC_WAIT. + * st.c (gfc_free_statement): Add case for EXEC_WAIT. + * trans-io.c (ioparam_type): Add IOPARM_ptype_wait. (gfc_st_parameter): + Add "wait" entry. (iocall): Add IOCALL_WAIT enumerator. + (gfc_build_io_library_fndecls): Add function declaration for st_wait. + (gfc_trans_open): Add mask bits for new I/O tags. + (gfc_trans_inquire): Add mask bits for new I/O tags. + (gfc_trans_wait): New translation function. + (build_dt): Add mask bits for new I/O tags. + * match.c (gfc_match_if) Add matcher for "wait". + * match.h (gfc_match_wait): Prototype for new function. + * ioparm.def: Add new I/O parameter definitions. + * parse.c (decode_statement): Add match for "wait" statement. + (next_statement): Add case for ST_WAIT. (gfc_ascii_statement): Same. + + 2008-04-03 Jakub Jelinek + + PR fortran/35786 + * openmp.c (resolve_omp_clauses): Diagnose if a clause symbol + isn't a variable. + + 2008-04-03 Tom Tromey + + * Make-lang.in (fortran_OBJS): New variable. + + 2008-04-03 Paolo Bonzini + + * f95-lang.c (insert_block): Kill. + + 2008-04-01 George Helffrich + + PR fortran/35154, fortran/23057 + * trans-common.c (create_common): Add decl to function + chain to preserve identifier scope in debug output. + + 2008-04-01 Joseph Myers + + * gfortran.texi: Include gpl_v3.texi instead of gpl.texi + * Make-lang.in (GFORTRAN_TEXI): Include gpl_v3.texi instead of + gpl.texi. + + 2008-03-30 Paul Thomas + + PR fortran/35740 + * resolve.c (resolve_function, resolve_call): If the procedure + is elemental do not look for noncopying intrinsics. + + 2008-03-29 Paul Thomas + + PR fortran/35698 + * trans-array.c (gfc_array_init_size): Set 'size' zero if + negative in one dimension. + + PR fortran/35702 + * trans-expr.c (gfc_trans_string_copy): Only assign a char + directly if the lhs and rhs types are the same. + + 2008-03-28 Daniel Franke + Paul Richard Thomas + + PR fortran/34714 + * primary.c (match_variable): Improved matching of function + result variables. + * resolve.c (resolve_allocate_deallocate): Removed checks if + the actual argument for STAT is a variable. + + 2008-03-28 Tobias Burnus + + * symbol.c (gfc_get_default_type): Fix error message; option + -fallow_leading_underscore should be -fallow-leading-underscore + + 2008-03-27 Jerry DeLisle + + PR fortran/35724 + * iresolve.c (gfc_resolve_cshift): Check for NULL symtree in test for + optional argument attribute. + + 2008-03-27 Tom Tromey + + * Make-lang.in: Revert automatic dependency patch. + + 2008-03-25 Tom Tromey + + * Make-lang.in: Remove .o targets. + (fortran_OBJS): New variable. + (fortran/gfortranspec.o): Move to fortran/. Reduce to variable + setting. + (GFORTRAN_D_OBJS): Update. + (GFORTRAN_TRANS_DEPS): Remove. + + 2008-03-24 Paul Thomas + + PR fortran/34813 + * resolve.c (resolve_structure_cons): It is an error to assign + NULL to anything other than a pointer or allocatable component. + + PR fortran/33295 + * resolve.c (resolve_symbol): If the symbol is a derived type, + resolve the derived type. If the symbol is a derived type + function, ensure that the derived type is visible in the same + namespace as the function. + + 2008-03-23 Tobias Schlüter + + * trans.h: Use fold_build in build1_v, build2_v and build3_v + macros. + * trans-openmp.c (gfc_trans_omp_critical, gfc_trans_omp_single): + Don't use build2_v macro. + + 2008-03-19 Daniel Franke + + PR fortran/35152 + * interface.c (gfc_procedure_use): Check for keyworded arguments in + procedures without explicit interfaces. + + 2008-03-16 Paul Thomas + + PR fortran/35470 + * resolve.c (check_assumed_size_reference): Only visit the + first reference and look directly at the highest dimension. + + 2008-03-15 Jerry DeLisle + + PR fortran/35184 + * trans-array.c (gfc_conv_array_index_offset): Remove unnecessary + assert. + + 2008-03-15 Daniel Franke + + PR fortran/35584 + * resolve.c (resolve_branch): Less strict and pessimistic warning + message. + + 2008-03-11 Paolo Bonzini + + * f95-lang.c (LANG_HOOKS_CLEAR_BINDING_STACK): Delete. + (gfc_be_parse_file): Call clear_binding_stack from here. + (gfc_clear_binding_stack): Rename to clear_binding_stack. + + 2008-03-09 Paul Thomas + + PR fortran/35474 + * module.c (mio_symtree_ref): After providing a symbol for a + missing equivalence member, resolve and NULL the fixups. + + 2008-03-09 Ralf Wildenhues + + * invoke.texi (Error and Warning Options): Document + -Wline-truncation. + + 2008-03-08 Francois-Xavier Coudert + + PR fortran/34956 + * trans-array.c (gfc_conv_ss_startstride): Fix the logic to avoid + checking bounds of absent optional arguments. + + 2008-03-06 Francois-Xavier Coudert + + PR fortran/33197 + * intrinsic.c (add_functions): Add simplification routines for + ERF, DERF, ERFC and DERFC. + * decl.c (gfc_match_suffix, gfc_match_subroutine): Change GNU + extensions into Fortran 2008 features. + * intrinsic.h (gfc_simplify_erf, gfc_simplify_erfc): New + prototypes. + * simplify.c (gfc_simplify_erf, gfc_simplify_erfc): New functions. + + 2008-03-03 Francois-Xavier Coudert + + PR fortran/33197 + * intrinsic.c (add_functions): Modify intrinsics ACOSH, ASINH, + ATANH, ERF, ERFC and GAMMA. Add intrinsics BESSEL_{J,Y}{0,1,N}, + ERFC_SCALED, LOG_GAMMA and HYPOT. + * intrinsic.h (gfc_check_hypot, gfc_simplify_hypot, + gfc_resolve_hypot): New prototypes. + * mathbuiltins.def: Add HYPOT builtin. Make complex versions of + ACOSH, ASINH and ATANH available. + * gfortran.h (GFC_ISYM_ERFC_SCALED, GFC_ISYM_HYPOT): New values. + * lang.opt: Add -std=f2008 option. + * libgfortran.h: Define GFC_STD_F2008. + * lang-specs.h: Add .f08 and .F08 file suffixes. + * iresolve.c (gfc_resolve_hypot): New function. + * parse.c (parse_contained): Allow empty CONTAINS for Fortran 2008. + * check.c (gfc_check_hypot): New function. + * trans-intrinsic.c (gfc_intrinsic_map): Define ERFC_SCALE builtin. + * options.c (set_default_std_flags): Allow Fortran 2008 by default. + (form_from_filename): Add .f08 suffix. + (gfc_handle_option): Handle -std=f2008 option. + * simplify.c (gfc_simplify_hypot): New function. + * gfortran.texi: Document Fortran 2008 status and file extensions. + * intrinsic.texi: Document new BESSEL_{J,Y}{0,1,N} intrinsics, + as well as HYPOT and ERFC_SCALED. Update documentation of ERF, + ERFC, GAMMA, LGAMMA, ASINH, ACOSH and ATANH. + * invoke.texi: Document the new -std=f2008 option. + + 2008-03-02 Jakub Jelinek + + * gfortranspec.c (lang_specific_driver): Update copyright notice + dates. + + 2008-02-29 Jerry DeLisle + + PR fortran/35059 + * expr.c (find_array_element): Modify traversing the constructor to + avoid trying to access NULL memory pointed to by next for the + last element. (find_array_section): Exit while loop if cons->next is + NULL. + * trans-expr.c (gfc_conv_scalar_char_value): Initialize gfc_typespec. + (gfc_conv_function_call): Same. + * decl.c (gfc_match_implicit): Same. + * trans-intrinsic.c (gfc_conv_intrinsic_sr_kind): Same. + + 2008-02-28 Daniel Franke + + PR fortran/31463 + PR fortran/33950 + PR fortran/34296 + * lang.opt: Added -Wreturn-type. + * options.c (gfc_handle_option): Recognize -Wreturn-type. + * trans-decl.c (gfc_trans_deferred_vars): Emit warnings for funtions + where the result value is not set. + (gfc_generate_function_code): Likewise. + (generate_local_decl): Emit warnings for funtions whose RESULT + variable is not set. + + 2008-02-28 Francois-Xavier Coudert + + PR fortran/34868 + * trans-expr.c (gfc_conv_variable): Don't build indirect + references when explicit interface is mandated. + * resolve.c (resolve_formal_arglist): Set attr.always_explicit + on the result symbol as well as the procedure symbol. + + 2008-02-27 Francois-Xavier Coudert + + PR fortran/33387 + * trans.h: Remove prototypes for gfor_fndecl_math_exponent4, + gfor_fndecl_math_exponent8, gfor_fndecl_math_exponent10 and + gfor_fndecl_math_exponent16. + * f95-lang.c (build_builtin_fntypes): Add new function types. + (gfc_init_builtin_functions): Add new builtins for nextafter, + frexp, ldexp, fabs, scalbn and inf. + * iresolve.c (gfc_resolve_rrspacing): Don't add hidden arguments. + (gfc_resolve_scale): Don't convert type of second argument. + (gfc_resolve_set_exponent): Likewise. + (gfc_resolve_size): Don't add hidden arguments. + * trans-decl.c: Remove gfor_fndecl_math_exponent4, + gfor_fndecl_math_exponent8, gfor_fndecl_math_exponent10 and + gfor_fndecl_math_exponent16. + * trans-intrinsic.c (gfc_intrinsic_map): Remove intrinsics + for scalbn, fraction, nearest, rrspacing, set_exponent and + spacing. + (gfc_conv_intrinsic_exponent): Directly call frexp. + (gfc_conv_intrinsic_fraction, gfc_conv_intrinsic_nearest, + gfc_conv_intrinsic_spacing, gfc_conv_intrinsic_rrspacing, + gfc_conv_intrinsic_scale, gfc_conv_intrinsic_set_exponent): New + functions. + (gfc_conv_intrinsic_function): Use the new functions above. + + 2008-02-26 Tobias Burnus + + PR fortran/35033 + * interface.c (check_operator_interface): Show better line for error + messages; fix constrains for user-defined assignment operators. + (gfc_extend_assign): Fix constrains for user-defined assignment + operators. + + 2008-02-26 Tom Tromey + + * trans-io.c (set_error_locus): Remove old location code. + * trans-decl.c (gfc_set_decl_location): Remove old location code. + * f95-lang.c (gfc_init): Remove test of USE_MAPPED_LOCATION. + * scanner.c (gfc_gobble_whitespace): Remove old location code. + (get_file): Likewise. + (preprocessor_line): Likewise. + (load_file): Likewise. + (gfc_new_file): Likewise. + * trans.c (gfc_trans_runtime_check): Remove old location code. + (gfc_get_backend_locus): Likewise. + (gfc_set_backend_locus): Likewise. + * data.c (gfc_assign_data_value): Remove old location code. + * error.c (show_locus): Remove old location code. + * gfortran.h (gfc_linebuf): Remove old location code. + (gfc_linebuf_linenum): Remove old-location variant. + + 2008-02-25 Francois-Xavier Coudert + + PR fortran/34729 + * trans-const.c (gfc_build_string_const): Don't call gettext. + (gfc_build_localized_string_const): New function. + * trans-const.h (gfc_build_localized_string_const): New prototype. + * trans.c (gfc_trans_runtime_check): Use + gfc_build_localized_string_const instead of gfc_build_string_const. + (gfc_call_malloc): Likewise. + (gfc_allocate_with_status): Likewise. + (gfc_allocate_array_with_status): Likewise. + (gfc_deallocate_with_status): Likewise. + (gfc_call_realloc): Likewise. + * trans-io.c (gfc_trans_io_runtime_check): Likewise. + + 2008-02-24 Tobias Schlüter + + * arith.c: Update copyright years. + * arith.h: Likewise. + * array.c: Likewise. + * bbt.c: Likewise. + * check.c: Likewise. + * data.c: Likewise. + * data.h: Likewise. + * decl.c: Likewise. + * dependency.c: Likewise. + * dependency.h: Likewise. + * dump-parse-tree.c: Likewise. + * error.c: Likewise. + * expr.c: Likewise. + * gfc-internals.texi: Likewise. + * gfortran.h: Likewise. + * gfortran.texi: Likewise. + * gfortranspec.c: Likewise. + * interface.c: Likewise. + * intrinsic.c: Likewise. + * intrinsic.h: Likewise. + * intrinsic.texi: Likewise. + * invoke.texi: Likewise. + * io.c: Likewise. + * iresolve.c: Likewise. + * iso-c-binding.def: Likewise. + * iso-fortran-env.def: Likewise. + * lang-specs.h: Likewise. + * lang.opt: Likewise. + * libgfortran.h: Likewise. + * match.c: Likewise. + * match.h: Likewise. + * matchexp.c: Likewise. + * misc.c: Likewise. + * module.c: Likewise. + * openmp.c: Likewise. + * options.c: Likewise. + * parse.c: Likewise. + * parse.h: Likewise. + * primary.c: Likewise. + * resolve.c: Likewise. + * scanner.c: Likewise. + * simplify.c: Likewise. + * st.c: Likewise. + * symbol.c: Likewise. + * target-memory.c: Likewise. + * target-memory.h: Likewise. + * trans-array.h: Likewise. + * trans-const.h: Likewise. + * trans-stmt.h: Likewise. + * trans-types.c: Likewise. + * trans-types.h: Likewise. + * types.def: Likewise. + + 2008-02-24 Jerry DeLisle + + PR fortran/35223 + * simplify.c (gfc_simplify_ibclr), (gfc_simplify_ibits), + (gfc_simplify_ibset): Remove call to range_check. + (simplify_cmplx), (gfc_simplify_dble), (gfc_simplify_float) + (gfc_simplify_real): Add call gfc_clear_ts to initialize the + temporary gfc_typspec variable. + + 2008-02-24 Tobias Schlüter + + * trans-array.c (gfc_conv_descriptor_data_get, + gfc_conv_descriptor_data_set_internal, + gfc_conv_descriptor_data_addr, gfc_conv_descriptor_offset, + gfc_conv_descriptor_dtype, gfc_conv_descriptor_dimension, + gfc_conv_descriptor_stride, gfc_conv_descriptor_lbound, + gfc_conv_descriptor_ubound, gfc_trans_create_temp_array, + gfc_conv_array_transpose, gfc_grow_array, + gfc_trans_array_constructor_subarray, + gfc_trans_array_constructor_value, gfc_trans_scalarized_loop_end, + gfc_array_init_size, gfc_array_allocate, gfc_array_deallocate, + gfc_conv_array_initializer, gfc_trans_array_bounds, + gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias, + gfc_get_dataptr_offset, gfc_conv_array_parameter, + gfc_trans_dealloc_allocated, get_full_array_size, + gfc_duplicate_allocatable, structure_alloc_comps): Use fold_buildN + instead of buildN. + * trans-expr.c (gfc_conv_expr_present, gfc_conv_missing_dummy, + gfc_conv_component_ref, gfc_conv_cst_int_power, + gfc_conv_function_call, gfc_trans_structur_assign): Likewise. + * trans-common.c (create_common): Likewise. + * trans-openmp.c (gfc_trans_omp_atomic, gfc_trans_omp_do): + Likewise. + * trans-const.c (gfc_conv_constant_to_tree): Likewise. + * trans-stmt.c (gfc_trans_goto, gfc_trans_return, gfc_trans_do, + gfc_trans_integer_select, gfc_trans_character_select, + gfc_trans_forall_loop, compute_overall_iter_number, + gfc_trans_forall_1, gfc_evaluate_where_mask, gfc_trans_allocate, + gfc_trans_deallocate): Likewise. + * trans.c (gfc_build_addr_expr, gfc_trans_runtime_check, + gfc_allocate_with_status, gfc_allocate_array_with_status, + gfc_deallocate_with_status): Likewise. + * f95-lang.c (gfc_truthvalue_conversion): Likewise. + * trans-io.c (set_parameter_const, set_parameter_value, + set_parameter_ref, set_string, set_internal_unit, io_result, + set_error_locus, nml_get_addr_expr, transfer_expr): Likewise. + * trans-decl.c (gfc_build_qualified_array, build_entry_thunks, + gfc_get_fake_result_decl, gfc_trans_auto_character_variable, + gfc_generate_function_code): Likewise. + * convert.c (convert): Likewise. + * trans-intrinsic.c (gfc_conv_intrinsic_conversion, + build_fixbound_expr, build_fix_expr, gfc_conv_intrinsic_aint, + gfc_conv_intrinsic_int, gfc_conv_intrinsic_imagpart, + gfc_conv_intrinsic_conjg, gfc_conv_intrinsic_abs, + gfc_conv_intrinsic_cmplx, gfc_conv_intrinsic_mod, + gfc_conv_intrinsic_dim, gfc_conv_intrinsic_dprod, + gfc_conv_intrinsic_ctime, gfc_conv_intrinsic_fdate, + gfc_conv_intrinsic_ttynam, gfc_conv_intrinsic_minmax, + gfc_conv_intrinsic_minmax_char, gfc_conv_intrinsic_count, + gfc_conv_intrinsic_arith, gfc_conv_intrinsic_dot_product, + gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_minmaxval, + gfc_conv_intrinsic_btest, gfc_conv_intrinsic_not, + gfc_conv_intrinsic_ibits, gfc_conv_intrinsic_ishft, + gfc_conv_intrinsic_ichar, gfc_conv_intrinsic_size, + gfc_conv_intrinsic_array_transfer, gfc_conv_intrinsic_transfer, + gfc_conv_allocated, gfc_conv_associated, gfc_conv_intrinsic_trim, + gfc_conv_intrinsic_repeat): Likewise. + + 2008-02-23 Francois-Xavier Coudert + + PR target/25477 + * trans-expr.c (gfc_conv_power_op): Use BUILT_IN_CPOW{F,,L}. + * f95-lang.c (gfc_init_builtin_functions): Define BUILT_IN_CPOW{F,,L}. + * trans.h (gfor_fndecl_math_cpow, gfor_fndecl_math_cpowf, + gfor_fndecl_math_cpowl10, gfor_fndecl_math_cpowl16): Remove. + * trans-decl.c: Likewise. + + 2008-02-22 Jerry DeLisle + + PR fortran/35059 + * expr.c (find_array_element): Modify traversing the constructor to + avoid trying to access NULL memory pointed to by next for the + last element. (find_array_section): Exit while loop if cons->next is + NULL. + + 2008-02-22 Jerry DeLisle + + PR fortran/34907 + * iresolve.c (resolve_mask_arg): Add gfc_clear_ts to initialize + structure. + (gfc_resolve_aint): Likewise. + (gfc_resolve_anint): Likewise. + (gfc_resolve_besn): Likewise. + (gfc_resolve_cshift): Likewise. + (gfc_resolve_ctime): Likewise. + (gfc_resolve_eoshift): Likewise. + (gfc_resolve_index_func): Likewise. + (gfc_resolve_isatty): Likewise. + (gfc_resolve_malloc): Likewise. + (gfc_resolve_rrspacing): Likewise. + (gfc_resolve_scale): Likewise. + (gfc_resolve_set_exponent): Likewise. + (gfc_resolve_spacing): Likewise. + (gfc_resolve_spacing): Likewise. + (gfc_resolve_fgetc): Likewise. + (gfc_resolve_fputc): Likewise. + (gfc_resolve_ftell): Likewise. + (gfc_resolve_ttynam): Likewise. + (gfc_resolve_alarm_sub): Likewise. + (gfc_resolve_mvbits): Likewise. + (gfc_resolve_getarg): Likewise. + (gfc_resolve_signal_sub): Likewise. + (gfc_resolve_exit): Likewise. + (gfc_resolve_flush): Likewise. + (gfc_resolve_free): Likewise. + (gfc_resolve_ctime_sub): Likewise. + (gfc_resolve_fgetc_sub): Likewise. + (gfc_resolve_fputc_sub): Likewise. + (gfc_resolve_fseek_sub): Likewise. + (gfc_resolve_ftell_sub): Likewise. + (gfc_resolve_ttynam_sub): Likewise. + + 2008-02-22 Ralf Wildenhues + + * gfc-internals.texi: Fix typos and markup nits. + * gfortran.texi: Likewise. + * intrinsic.texi: Likewise. + + 2008-02-21 Richard Guenther + + * trans-expr.c (gfc_conv_expr_op): Expand INTRINSIC_PARENTHESES + as unary PAREN_EXPR for real and complex typed expressions. + (gfc_conv_unary_op): Fold the built tree. + + 2008-02-20 Tobias Burnus + + PR fortran/34997 + * match.c (gfc_match_name): Improve error message for '$'. + + 2008-02-19 Daniel Franke + + PR fortran/35030 + * expr.c (gfc_check_pointer_assign): Add type and kind information + to type-mismatch message. + (gfc_check_assign): Unify error messages. + + 2008-02-16 Francois-Xavier Coudert + + PR fortran/34952 + * gfortran.texi: Create new section for unimplemented extensions. + Add "STRUCTURE and RECORD" and "ENCODE and DECODE statements". + Remove "smaller projects" list. Fix a few typos. + + 2008-02-15 Francois-Xavier Coudert + + * intrinsic.texi: Rename INDEX node to avoid clashing with + index.html on case-insensitive systems. + + 2008-02-15 Francois-Xavier Coudert + + PR fortran/35150 + * trans-expr.c (gfc_conv_function_call): Force evaluation of + se->expr. + + 2008-02-10 Daniel Franke + + PR fortran/35019 + * lang.opt: Allow '-J' next to '-J ', + likewise '-I ' and '-I'. + + 2008-02-06 Kaveh R. Ghazi + + PR other/35107 + * Make-lang.in (f951): Add $(GMPLIBS). + + 2008-02-05 Francois-Xavier Coudert + + PR fortran/35037 + * trans-common.c (build_field): Mark fields as volatile when needed. + + 2008-02-05 Tobias Burnus + + PR fortran/35093 + * data.c (gfc_assign_data_value): Only free "size" if + it has not already been freed. + + 2008-02-05 Paul Thomas + + PR fortran/34945 + * array.c (match_array_element_spec): Remove check for negative + array size. + (gfc_resolve_array_spec): Add check for negative size. + + 2008-02-05 Paul Thomas + + PR fortran/32315 + * data.c (gfc_assign_data_value): Add bounds check for array + references. + + 2008-02-04 Daniel Franke + + * resolve.c (resolve_where): Fix typo. + (gfc_resolve_where_code_in_forall): Likewise. + + 2008-02-03 Paul Thomas + + PR fortran/32760 + * resolve.c (resolve_allocate_deallocate): New function. + (resolve_code): Call it for allocate and deallocate. + * match.c (gfc_match_allocate, gfc_match_deallocate) : Remove + the checking of the STAT tag and put in above new function. + * primary,c (match_variable): Do not fix flavor of host + associated symbols yet if the type is not known. + + 2008-01-31 Paul Thomas + + PR fortran/34910 + * expr.c (gfc_check_assign): It is an error to assign + to a sibling procedure. + + 2008-01-30 Paul Thomas + + PR fortran/34975 + * symbol.c (gfc_delete_symtree, gfc_undo_symbols): Rename + delete_symtree to gfc_delete_symtree. + * gfortran.h : Add prototype for gfc_delete_symtree. + * module.c (load_generic_interfaces): Transfer symbol to a + unique symtree and delete old symtree, instead of renaming. + (read_module): The rsym and the found symbol are the same, so + the found symtree can be deleted. + + PR fortran/34429 + * decl.c (match_char_spec): Remove the constraint on deferred + matching of functions and free the length expression. + delete_symtree to gfc_delete_symtree. + (gfc_match_type_spec): Whitespace. + (gfc_match_function_decl): Defer characteristic association for + all types except BT_UNKNOWN. + * parse.c (decode_specification_statement): Only derived type + function matching is delayed to the end of specification. + + 2008-01-28 Tobias Burnus + + PR libfortran/34980 + * simplify.c (gfc_simplify_shape): Simplify rank zero arrays. + + 2008-01-27 Jerry DeLisle + + PR fortran/34990 + * array.c (gfc_check_constructor_type): Revert clearing the expression. + + 2008-01-26 Tobias Burnus + + PR fortran/34848 + * trans-expr.c (gfc_conv_function_call): Don't call + gfc_add_interface_mapping if the expression is NULL. + + 2008-01-26 Jerry DeLisle + + PR fortran/31610 + * trans-array.c (gfc_trans_create_temp_array): Remove call to + gcc_assert (integer_zerop (loop->from[n])). + + 2008-01-25 Daniel Franke + + PR fortran/34661 + * resolve.c (resolve_where): Added check if user-defined assignment + operator is an elemental subroutine. + (gfc_resolve_where_code_in_forall): Likewise. + + 2008-01-24 Daniel Franke + + PR fortran/33375 + PR fortran/34858 + * gfortran.h: Revert changes from 2008-01-17. + * match.c: Likewise. + * symbol.c: Likewise. + (gfc_undo_symbols): Undo namespace changes related to common blocks. + + 2008-01-24 Daniel Franke + + PR fortran/34202 + * data.c (formalize_structure_cons): Skip formalization on + empty structures. + + 2008-01-24 Daniel Franke + + * gfortran.texi (OpenMP): Extended existing documentation. + (contributors): Added major contributors of 2008 that were + not listed yet. + (proposed extensions): Removed implemented items. + + 2008-01-24 Paul Thomas + + PR fortran/34872 + * parse.c (next_statement) : If ST_GET_FCN_CHARACTERISTICS is + seen, check for a statement label and, if present, delete it + and set the locus to the start of the statement. + + 2008-01-22 Paul Thomas + + PR fortran/34875 + * trans-io.c (gfc_trans_transfer): If the array reference in a + read has a vector subscript, use gfc_conv_subref_array_arg to + copy back the temporary. + + 2008-01-22 Tobias Burnus + + PR fortran/34848 + * interface.c (compare_actual_formal): Fix adding type + to missing_arg_type for absent optional arguments. + + 2008-01-22 Tobias Burnus + + PR fortran/34907 + * parse.c (parse_spec): Change = into ==. + + 2008-01-22 Daniel Franke + + PR fortran/34915 + * expr.c (check_elemental): Fix check for valid data types. + + 2008-01-22 Tobias Burnus + + PR fortran/34899 + * scanner.c (load_line): Support continuation lines. + * invoke.texi (-Wtabs): Document this. + + 2008-01-22 Paul Thomas + + PR fortran/34896 + * module.c (read_module): Set use_rename attribute. + + 2007-01-21 Tobias Burnus + + PR fortran/34901 + * interface.c (compare_parameter): Improved error message + for arguments of same type and mismatched kinds. + + 2008-01-20 Paul Thomas + + PR fortran/34861 + * resolve.c (resolve_entries): Do not do an array bounds check + if the result symbols are the same. + + PR fortran/34854 + * module.c (read_module) : Hide the symtree of the previous + version of the symbol if this symbol is renamed. + + 2008-01-20 Paul Thomas + + PR fortran/34784 + * array.c (gfc_check_constructor_type): Clear the expression ts + so that the checking starts from the deepest level of array + constructor. + * primary.c (match_varspec): If an unknown type is changed to + default character and the attempt to match a substring fails, + change it back to unknown. + + PR fortran/34785 + * trans-array.c (gfc_add_loop_ss_code) : If ss->string_length is + NULL for an array constructor, use the cl.length expression to + build it. + (gfc_conv_array_parameter): Change call to gfc_evaluate_now to + a tree assignment. + + 2008-01-19 Thomas Koenig + + PR fortran/34817 + PR fortran/34838 + * iresolve.c (gfc_resolve_all): Remove conversion of mask + argument to kind=1 by removing call to resolve_mask_arg(). + (gfc_resolve_any): Likewise. + + 2008-01-19 Tobias Burnus + + PR fortran/34760 + * primary.c (match_variable): Handle FL_UNKNOWN without + uneducated guessing. + (match_variable): Improve error message. + + 2008-01-18 Tobias Burnus + + PR fortran/32616 + * interface.c (get_expr_storage_size): Return storage size + for array element designators. + (compare_actual_formal): Reject unequal string sizes for + assumed-shape dummy arguments. And fix error message for + array-sections with vector subscripts. + + 2008-01-17 Jerry DeLisle + + PR fortran/34556 + * simplify.c (is_constant_array_expr): New static function that returns + true if the given expression is an array and is constant. + (gfc_simplify_reshape): Use new function. + + 2008-01-17 H.J. Lu + + PR fortran/33375 + * symbol.c (free_common_tree): Renamed to ... + (gfc_free_common_tree): This. Remove static. + (gfc_free_namespace): Updated. + + * gfortran.h (gfc_free_common_tree): New. + + * match.c (gfc_match_common): Call gfc_free_common_tree () with + gfc_current_ns->common_root and set gfc_current_ns->common_root + to NULL on syntax error. + + 2008-01-18 Richard Sandiford + + PR fortran/34686 + * trans-expr.c (gfc_conv_function_call): Use proper + type for returned character pointers. + + 2008-01-17 Paul Thomas + + PR fortran/34429 + PR fortran/34431 + PR fortran/34471 + * decl.c : Remove gfc_function_kind_locus and + gfc_function_type_locus. Add gfc_matching_function. + (match_char_length): If matching a function and the length + does not match, return MATCH_YES and try again later. + (gfc_match_kind_spec): The same. + (match_char_kind): The same. + (gfc_match_type_spec): The same for numeric and derived types. + (match_prefix): Rename as gfc_match_prefix. + (gfc_match_function_decl): Except for function valued character + lengths, defer applying kind, type and charlen info until the + end of specification block. + gfortran.h (gfc_statement): Add ST_GET_FCN_CHARACTERISTICS. + parse.c (decode_specification_statement): New function. + (decode_statement): Call it when a function has kind = -1. Set + and reset gfc_matching function, as function statement is being + matched. + (match_deferred_characteristics): Simplify with a single call + to gfc_match_prefix. Do appropriate error handling. In any + case, make sure that kind = -1 is reset or corrected. + (parse_spec): Call above on seeing ST_GET_FCN_CHARACTERISTICS. + Throw an error if kind = -1 after last specification statement. + parse.h : Prototype for gfc_match_prefix. + + 2008-01-16 Tobias Burnus + + PR fortran/34796 + * interface.c (compare_parameter): Allow AS_DEFERRED array + elements and reject attr.pointer array elemenents. + (get_expr_storage_size): Return storage size of elements of + assumed-shape and pointer arrays. + + 2008-01-15 Sebastian Pop + + * f95-lang.c (gfc_init_builtin_functions): Initialize GOMP builtins + for flag_tree_parallelize_loops. + + 2008-01-15 Thomas Koenig + + PR libfortran/34671 + * iresolve.c (gfc_resolve_all): Call resolve_mask_arg. + (gfc_resolve_any): Likewise. + (gfc_resolve_count): Likewise. Don't append kind of + argument to function name. + + 2008-01-13 Tobias Burnus + + PR fortran/34665 + * resolve.c (resolve_actual_arglist): For expressions, + also check for assume-sized arrays. + * interface.c (compare_parameter): Move F2003 character checks + here, print error messages here, reject elements of + assumed-shape array as argument to dummy arrays. + (compare_actual_formal): Update for the changes above. + + 2008-01-13 Tobias Burnus + + PR fortran/34763 + * decl.c (contained_procedure): Only check directly preceeding state. + + 2008-01-13 Tobias Burnus + + PR fortran/34759 + * check.c (gfc_check_shape): Accept array ranges of + assumed-size arrays. + + 2008-01-12 Jerry DeLisle + + PR fortran/34432 + * match.c (gfc_match_name): Don't error if leading character is a '(', + just return MATCH_NO. + + 2008-01-11 Jerry DeLisle + + PR fortran/34722 + * trans-io.c (create_dummy_iostat): Commit the symbol. + + 2008-01-11 Paul Thomas + + PR fortran/34537 + * simplify.c (gfc_simplify_transfer): Return NULL if the size + of the element is unavailable and only assign character length + to the result, if 'mold' is constant. + + 2008-01-10 Paul Thomas + + PR fortran/34396 + * trans-array.c (gfc_trans_array_ctor_element): Use gfc_trans_string_copy + to assign strings and perform bounds checks on the string length. + (get_array_ctor_strlen): Remove bounds checking. + (gfc_trans_array_constructor): Initialize string length checking. + * trans-array.h : Add prototype for gfc_trans_string_copy. + + 2008-01-08 Richard Guenther + + PR fortran/34706 + PR tree-optimization/34683 + * trans-types.c (gfc_get_array_type_bounds): Use an array type + with known size for accesses if that is known. + + 2008-01-08 Paul Thomas + + PR fortran/34476 + * expr.c (find_array_element): Check that the array bounds are + constant before using them. Use lower, as well as upper bound. + (check_restricted): Allow implied index variable. + + 2008-01-08 Paul Thomas + + PR fortran/34681 + * trans_array.c (gfc_trans_deferred_array): Do not null the + data pointer on entering scope, nor deallocate it on leaving + scope, if the symbol has the 'save' attribute. + + PR fortran/34704 + * trans_decl.c (gfc_finish_var_decl): Derived types with + allocatable components and an initializer must be TREE_STATIC. + + 2008-01-07 Paul Thomas + + PR fortran/34672 + * module.c (write_generic): Rewrite completely. + (write_module): Change call to write_generic. + + 2008-01-06 Jerry DeLisle + + PR fortran/34659 + * scanner.c (load_line): Do not count ' ' as printable when checking for + continuations. + + 2008-01-06 Paul Thomas + + PR fortran/34545 + * module.c (load_needed): If the namespace has no proc_name + give it the module symbol. + + 2008-01-06 Jerry DeLisle + + PR fortran/34387 + * trans-expr.c (gfc_conv_missing_dummy): Use a temporary to type convert + the dummy variable expression, test for NULL, and pass the variable + address to the called function. + + 2007-01-06 Tobias Burnus + + PR fortran/34658 + * match.c (gfc_match_common): Remove blank common in + DATA BLOCK warning. + * resolve.c (resolve_common_vars): New function. + (resolve_common_blocks): Move checks to resolve_common_vars + and invoke that function. + (resolve_types): Call resolve_common_vars for blank commons. + + 2008-01-06 Tobias Burnus + + PR fortran/34655 + * resolve.c (resolve_equivalence_derived): Reject derived types with + default initialization if equivalenced with COMMON variable. + + 2008-01-06 Tobias Burnus + + PR fortran/34654 + * io.c (check_io_constraints): Disallow unformatted I/O for + internal units. + + 2008-01-06 Tobias Burnus + + PR fortran/34660 + * resolve.c (resolve_formal_arglist): Reject dummy procedure in + ELEMENTAL functions. + + 2008-01-06 Tobias Burnus + + PR fortran/34662 + * interface.c (compare_actual_formal): Reject parameter + actual to intent(out) dummy. + + 2008-01-04 Tobias Burnus + + PR fortran/34557 + * primary.c (match_varspec): Gobble whitespace before + checking for '('. diff -Nrcpad gcc-4.3.3/gcc/fortran/Make-lang.in gcc-4.4.0/gcc/fortran/Make-lang.in *** gcc-4.3.3/gcc/fortran/Make-lang.in Thu Dec 4 23:00:19 2008 --- gcc-4.4.0/gcc/fortran/Make-lang.in Thu Dec 11 11:29:38 2008 *************** *** 1,6 **** # -*- makefile -*- # Top level makefile fragment for GNU gfortran, the GNU Fortran 95 compiler. ! # Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. # Contributed by Paul Brook --- 1,7 ---- # -*- makefile -*- # Top level makefile fragment for GNU gfortran, the GNU Fortran 95 compiler. ! # Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software ! # Foundation, Inc. # Contributed by Paul Brook *************** fortran-warn = $(STRICT_WARN) *** 52,72 **** # from the parse tree to GENERIC F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \ ! fortran/check.o fortran/data.o fortran/decl.o fortran/dump-parse-tree.o \ ! fortran/error.o fortran/expr.o fortran/interface.o \ ! fortran/intrinsic.o fortran/io.o fortran/iresolve.o \ fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \ fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \ fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \ fortran/symbol.o fortran/target-memory.o ! F95_OBJS = $(F95_PARSER_OBJS) \ fortran/convert.o fortran/dependency.o fortran/f95-lang.o \ fortran/trans.o fortran/trans-array.o fortran/trans-common.o \ fortran/trans-const.o fortran/trans-decl.o fortran/trans-expr.o \ fortran/trans-intrinsic.o fortran/trans-io.o fortran/trans-openmp.o \ fortran/trans-stmt.o fortran/trans-types.o # # Define the names for selecting gfortran in LANGUAGES. fortran: f951$(exeext) --- 53,75 ---- # from the parse tree to GENERIC F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \ ! fortran/check.o fortran/cpp.o fortran/data.o fortran/decl.o \ ! fortran/dump-parse-tree.o fortran/error.o fortran/expr.o \ ! fortran/interface.o fortran/intrinsic.o fortran/io.o fortran/iresolve.o \ fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \ fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \ fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \ fortran/symbol.o fortran/target-memory.o ! F95_OBJS = $(F95_PARSER_OBJS) $(FORTRAN_TARGET_OBJS) \ fortran/convert.o fortran/dependency.o fortran/f95-lang.o \ fortran/trans.o fortran/trans-array.o fortran/trans-common.o \ fortran/trans-const.o fortran/trans-decl.o fortran/trans-expr.o \ fortran/trans-intrinsic.o fortran/trans-io.o fortran/trans-openmp.o \ fortran/trans-stmt.o fortran/trans-types.o + fortran_OBJS = $(F95_OBJS) gfortranspec.o + # # Define the names for selecting gfortran in LANGUAGES. fortran: f951$(exeext) *************** fortran: f951$(exeext) *** 74,80 **** # Tell GNU make to ignore files by these names if they exist. .PHONY: fortran ! gfortranspec.o: $(srcdir)/fortran/gfortranspec.c $(SYSTEM_H) $(TM_H) $(GCC_H) $(CONFIG_H) (SHLIB_LINK='$(SHLIB_LINK)'; \ $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \ $(INCLUDES) $(srcdir)/fortran/gfortranspec.c) --- 77,84 ---- # Tell GNU make to ignore files by these names if they exist. .PHONY: fortran ! gfortranspec.o: $(srcdir)/fortran/gfortranspec.c $(SYSTEM_H) $(TM_H) $(GCC_H) \ ! $(CONFIG_H) coretypes.h intl.h (SHLIB_LINK='$(SHLIB_LINK)'; \ $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \ $(INCLUDES) $(srcdir)/fortran/gfortranspec.c) *************** gfortran-cross$(exeext): gfortran$(exeex *** 94,100 **** f951$(exeext): $(F95_OBJS) \ $(BACKEND) $(LIBDEPS) attribs.o $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ \ ! $(F95_OBJS) $(BACKEND) $(LIBS) attribs.o $(GMPLIBS) gt-fortran-trans.h : s-gtype; @true # --- 98,104 ---- f951$(exeext): $(F95_OBJS) \ $(BACKEND) $(LIBDEPS) attribs.o $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ \ ! $(F95_OBJS) $(BACKEND) $(LIBS) attribs.o $(BACKENDLIBS) gt-fortran-trans.h : s-gtype; @true # *************** doc/gfc-internals.pdf: $(GFC_INTERNALS_T *** 207,215 **** # Create or recreate the gfortran private include file directory. install-finclude-dir: installdirs ! -rm -rf $(DESTDIR)$(libsubdir)/finclude ! mkdir $(DESTDIR)$(libsubdir)/finclude ! -chmod a+rx $(DESTDIR)$(libsubdir)/finclude # # Install hooks: # f951 is installed elsewhere as part of $(COMPILERS). --- 211,217 ---- # Create or recreate the gfortran private include file directory. install-finclude-dir: installdirs ! $(mkinstalldirs) -m 0755 $(DESTDIR)$(libsubdir)/finclude # # Install hooks: # f951 is installed elsewhere as part of $(COMPILERS). *************** GFORTRAN_TRANS_DEPS = fortran/gfortran.h *** 310,323 **** $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) coretypes.h $(GGC_H) fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ ! gt-fortran-f95-lang.h gtype-fortran.h $(CGRAPH_H) $(TARGET_H) \ $(BUILTINS_DEF) fortran/types.def ! fortran/scanner.o: toplev.h fortran/convert.o: $(GFORTRAN_TRANS_DEPS) ! fortran/trans.o: $(GFORTRAN_TRANS_DEPS) fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h \ ! $(CGRAPH_H) $(TARGET_H) $(FUNCTION_H) $(FLAGS_H) $(RTL_H) $(TREE_GIMPLE_H) \ ! $(TREE_DUMP_H) fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \ $(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H) dwarf2out.h fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS) --- 312,325 ---- $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) coretypes.h $(GGC_H) fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ ! gt-fortran-f95-lang.h gtype-fortran.h $(CGRAPH_H) $(TARGET_H) fortran/cpp.h \ $(BUILTINS_DEF) fortran/types.def ! fortran/scanner.o: toplev.h fortran/cpp.h fortran/convert.o: $(GFORTRAN_TRANS_DEPS) ! fortran/trans.o: $(GFORTRAN_TRANS_DEPS) tree-iterator.h fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h \ ! $(CGRAPH_H) $(TARGET_H) $(FUNCTION_H) $(FLAGS_H) $(RTL_H) $(GIMPLE_H) \ ! $(TREE_DUMP_H) debug.h fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \ $(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H) dwarf2out.h fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS) *************** fortran/dependency.o: $(GFORTRAN_TRANS_D *** 333,336 **** fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS) $(TARGET_H) $(RTL_H) fortran/resolve.o: fortran/dependency.h fortran/data.h fortran/target-memory.h fortran/data.o: fortran/data.h ! fortran/options.o: $(PARAMS_H) $(TARGET_H) --- 335,341 ---- fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS) $(TARGET_H) $(RTL_H) fortran/resolve.o: fortran/dependency.h fortran/data.h fortran/target-memory.h fortran/data.o: fortran/data.h ! fortran/options.o: $(PARAMS_H) $(TARGET_H) fortran/cpp.h ! fortran/cpp.o: fortran/cpp.c $(BASEVER) incpath.h incpath.o ! $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) -DBASEVER=$(BASEVER_s) \ ! $< $(OUTPUT_OPTION) diff -Nrcpad gcc-4.3.3/gcc/fortran/arith.c gcc-4.4.0/gcc/fortran/arith.c *** gcc-4.3.3/gcc/fortran/arith.c Fri Dec 14 15:11:17 2007 --- gcc-4.4.0/gcc/fortran/arith.c Tue Nov 25 05:55:55 2008 *************** *** 1,5 **** /* Compiler arithmetic ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught --- 1,5 ---- /* Compiler arithmetic ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Andy Vaught *************** along with GCC; see the file COPYING3. *** 35,49 **** It's easily implemented with a few calls though. */ void ! gfc_mpfr_to_mpz (mpz_t z, mpfr_t x) { mp_exp_t e; e = mpfr_get_z_exp (z, x); - /* MPFR 2.0.1 (included with GMP 4.1) has a bug whereby mpfr_get_z_exp - may set the sign of z incorrectly. Work around that here. */ - if (mpfr_sgn (x) != mpz_sgn (z)) - mpz_neg (z, z); if (e > 0) mpz_mul_2exp (z, z, e); --- 35,53 ---- It's easily implemented with a few calls though. */ void ! gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where) { mp_exp_t e; + if (mpfr_inf_p (x) || mpfr_nan_p (x)) + { + gfc_error ("Conversion of an Infinity or Not-a-Number at %L " + "to INTEGER", where); + mpz_set_ui (z, 0); + return; + } + e = mpfr_get_z_exp (z, x); if (e > 0) mpz_mul_2exp (z, z, e); *************** gfc_arith_init_1 (void) *** 123,146 **** { gfc_integer_info *int_info; gfc_real_info *real_info; ! mpfr_t a, b, c; ! mpz_t r; int i; mpfr_set_default_prec (128); mpfr_init (a); - mpz_init (r); /* Convert the minimum and maximum values for each kind into their GNU MP representation. */ for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++) { /* Huge */ - mpz_set_ui (r, int_info->radix); - mpz_pow_ui (r, r, int_info->digits); - mpz_init (int_info->huge); ! mpz_sub_ui (int_info->huge, r, 1); /* These are the numbers that are actually representable by the target. For bases other than two, this needs to be changed. */ --- 127,147 ---- { gfc_integer_info *int_info; gfc_real_info *real_info; ! mpfr_t a, b; int i; mpfr_set_default_prec (128); mpfr_init (a); /* Convert the minimum and maximum values for each kind into their GNU MP representation. */ for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++) { /* Huge */ mpz_init (int_info->huge); ! mpz_set_ui (int_info->huge, int_info->radix); ! mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits); ! mpz_sub_ui (int_info->huge, int_info->huge, 1); /* These are the numbers that are actually representable by the target. For bases other than two, this needs to be changed. */ *************** gfc_arith_init_1 (void) *** 164,171 **** mpfr_set_z (a, int_info->huge, GFC_RND_MODE); mpfr_log10 (a, a, GFC_RND_MODE); mpfr_trunc (a, a); ! gfc_mpfr_to_mpz (r, a); ! int_info->range = mpz_get_si (r); } mpfr_clear (a); --- 165,171 ---- mpfr_set_z (a, int_info->huge, GFC_RND_MODE); mpfr_log10 (a, a, GFC_RND_MODE); mpfr_trunc (a, a); ! int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); } mpfr_clear (a); *************** gfc_arith_init_1 (void) *** 176,224 **** mpfr_init (a); mpfr_init (b); - mpfr_init (c); /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */ ! /* a = 1 - b**(-p) */ ! mpfr_set_ui (a, 1, GFC_RND_MODE); ! mpfr_set_ui (b, real_info->radix, GFC_RND_MODE); ! mpfr_pow_si (b, b, -real_info->digits, GFC_RND_MODE); ! mpfr_sub (a, a, b, GFC_RND_MODE); ! ! /* c = b**(emax-1) */ ! mpfr_set_ui (b, real_info->radix, GFC_RND_MODE); ! mpfr_pow_ui (c, b, real_info->max_exponent - 1, GFC_RND_MODE); ! /* a = a * c = (1 - b**(-p)) * b**(emax-1) */ ! mpfr_mul (a, a, c, GFC_RND_MODE); ! /* a = (1 - b**(-p)) * b**(emax-1) * b */ ! mpfr_mul_ui (a, a, real_info->radix, GFC_RND_MODE); ! mpfr_init (real_info->huge); ! mpfr_set (real_info->huge, a, GFC_RND_MODE); /* tiny(x) = b**(emin-1) */ - mpfr_set_ui (b, real_info->radix, GFC_RND_MODE); - mpfr_pow_si (b, b, real_info->min_exponent - 1, GFC_RND_MODE); - mpfr_init (real_info->tiny); ! mpfr_set (real_info->tiny, b, GFC_RND_MODE); /* subnormal (x) = b**(emin - digit) */ - mpfr_set_ui (b, real_info->radix, GFC_RND_MODE); - mpfr_pow_si (b, b, real_info->min_exponent - real_info->digits, - GFC_RND_MODE); - mpfr_init (real_info->subnormal); ! mpfr_set (real_info->subnormal, b, GFC_RND_MODE); /* epsilon(x) = b**(1-p) */ - mpfr_set_ui (b, real_info->radix, GFC_RND_MODE); - mpfr_pow_si (b, b, 1 - real_info->digits, GFC_RND_MODE); - mpfr_init (real_info->epsilon); ! mpfr_set (real_info->epsilon, b, GFC_RND_MODE); /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */ mpfr_log10 (a, real_info->huge, GFC_RND_MODE); --- 176,218 ---- mpfr_init (a); mpfr_init (b); /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */ ! /* 1 - b**(-p) */ ! mpfr_init (real_info->huge); ! mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE); ! mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); ! mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE); ! mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE); ! /* b**(emax-1) */ ! mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); ! mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE); ! /* (1 - b**(-p)) * b**(emax-1) */ ! mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE); ! /* (1 - b**(-p)) * b**(emax-1) * b */ ! mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix, ! GFC_RND_MODE); /* tiny(x) = b**(emin-1) */ mpfr_init (real_info->tiny); ! mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE); ! mpfr_pow_si (real_info->tiny, real_info->tiny, ! real_info->min_exponent - 1, GFC_RND_MODE); /* subnormal (x) = b**(emin - digit) */ mpfr_init (real_info->subnormal); ! mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE); ! mpfr_pow_si (real_info->subnormal, real_info->subnormal, ! real_info->min_exponent - real_info->digits, GFC_RND_MODE); /* epsilon(x) = b**(1-p) */ mpfr_init (real_info->epsilon); ! mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE); ! mpfr_pow_si (real_info->epsilon, real_info->epsilon, ! 1 - real_info->digits, GFC_RND_MODE); /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */ mpfr_log10 (a, real_info->huge, GFC_RND_MODE); *************** gfc_arith_init_1 (void) *** 227,257 **** /* a = min(a, b) */ mpfr_min (a, a, b, GFC_RND_MODE); - mpfr_trunc (a, a); ! gfc_mpfr_to_mpz (r, a); ! real_info->range = mpz_get_si (r); /* precision(x) = int((p - 1) * log10(b)) + k */ mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); mpfr_log10 (a, a, GFC_RND_MODE); - mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE); mpfr_trunc (a, a); ! gfc_mpfr_to_mpz (r, a); ! real_info->precision = mpz_get_si (r); /* If the radix is an integral power of 10, add one to the precision. */ for (i = 10; i <= real_info->radix; i *= 10) if (i == real_info->radix) real_info->precision++; ! mpfr_clear (a); ! mpfr_clear (b); ! mpfr_clear (c); } - - mpz_clear (r); } --- 221,243 ---- /* a = min(a, b) */ mpfr_min (a, a, b, GFC_RND_MODE); mpfr_trunc (a, a); ! real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); /* precision(x) = int((p - 1) * log10(b)) + k */ mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); mpfr_log10 (a, a, GFC_RND_MODE); mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE); mpfr_trunc (a, a); ! real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE); /* If the radix is an integral power of 10, add one to the precision. */ for (i = 10; i <= real_info->radix; i *= 10) if (i == real_info->radix) real_info->precision++; ! mpfr_clears (a, b, NULL); } } *************** gfc_arith_done_1 (void) *** 271,282 **** } for (rp = gfc_real_kinds; rp->kind; rp++) ! { ! mpfr_clear (rp->epsilon); ! mpfr_clear (rp->huge); ! mpfr_clear (rp->tiny); ! mpfr_clear (rp->subnormal); ! } } --- 257,280 ---- } for (rp = gfc_real_kinds; rp->kind; rp++) ! mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL); ! } ! ! ! /* Given a wide character value and a character kind, determine whether ! the character is representable for that kind. */ ! bool ! gfc_check_character_range (gfc_char_t c, int kind) ! { ! /* As wide characters are stored as 32-bit values, they're all ! representable in UCS=4. */ ! if (kind == 4) ! return true; ! ! if (kind == 1) ! return c <= 255 ? true : false; ! ! gcc_unreachable (); } *************** gfc_check_real_range (mpfr_t p, int kind *** 328,356 **** 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) ! { ! mpfr_set_inf (p, mpfr_sgn (p)); ! retval = ARITH_OK; ! } else retval = ARITH_OVERFLOW; } --- 326,352 ---- mpfr_init (q); mpfr_abs (q, p, GFC_RND_MODE); + retval = ARITH_OK; + if (mpfr_inf_p (p)) { ! if (gfc_option.flag_range_check != 0) retval = ARITH_OVERFLOW; } else if (mpfr_nan_p (p)) { ! if (gfc_option.flag_range_check != 0) retval = ARITH_NAN; } else if (mpfr_sgn (q) == 0) ! { ! mpfr_clear (q); ! return retval; ! } else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0) { if (gfc_option.flag_range_check == 0) ! mpfr_set_inf (p, mpfr_sgn (p)); else retval = ARITH_OVERFLOW; } *************** gfc_check_real_range (mpfr_t p, int kind *** 366,372 **** } else mpfr_set_ui (p, 0, GFC_RND_MODE); - retval = ARITH_OK; } else retval = ARITH_UNDERFLOW; --- 362,367 ---- *************** gfc_check_real_range (mpfr_t p, int kind *** 384,389 **** --- 379,385 ---- en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1; mpfr_set_emin ((mp_exp_t) en); mpfr_set_emax ((mp_exp_t) gfc_real_kinds[i].max_exponent); + mpfr_check_range (q, 0, GFC_RND_MODE); mpfr_subnormalize (q, 0, GFC_RND_MODE); /* Reset emin and emax. */ *************** gfc_check_real_range (mpfr_t p, int kind *** 395,405 **** mpfr_neg (p, q, GMP_RNDN); else mpfr_set (p, q, GMP_RNDN); - - retval = ARITH_OK; } - else - retval = ARITH_OK; mpfr_clear (q); --- 391,397 ---- *************** gfc_arith_times (gfc_expr *op1, gfc_expr *** 762,769 **** mpfr_mul (y, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE); mpfr_add (result->value.complex.i, x, y, GFC_RND_MODE); ! mpfr_clear (x); ! mpfr_clear (y); break; default: --- 754,760 ---- mpfr_mul (y, op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE); mpfr_add (result->value.complex.i, x, y, GFC_RND_MODE); ! mpfr_clears (x, y, NULL); break; default: *************** gfc_arith_divide (gfc_expr *op1, gfc_exp *** 841,849 **** mpfr_div (result->value.complex.i, result->value.complex.i, div, GFC_RND_MODE); ! mpfr_clear (x); ! mpfr_clear (y); ! mpfr_clear (div); break; default: --- 832,838 ---- mpfr_div (result->value.complex.i, result->value.complex.i, div, GFC_RND_MODE); ! mpfr_clears (x, y, div, NULL); break; default: *************** gfc_arith_divide (gfc_expr *op1, gfc_exp *** 862,891 **** static void complex_reciprocal (gfc_expr *op) { ! mpfr_t mod, a, re, im; gfc_set_model (op->value.complex.r); mpfr_init (mod); ! mpfr_init (a); ! mpfr_init (re); ! mpfr_init (im); mpfr_mul (mod, op->value.complex.r, op->value.complex.r, GFC_RND_MODE); ! mpfr_mul (a, op->value.complex.i, op->value.complex.i, GFC_RND_MODE); ! mpfr_add (mod, mod, a, GFC_RND_MODE); ! ! mpfr_div (re, op->value.complex.r, mod, GFC_RND_MODE); ! mpfr_neg (im, op->value.complex.i, GFC_RND_MODE); ! mpfr_div (im, im, mod, GFC_RND_MODE); ! mpfr_set (op->value.complex.r, re, GFC_RND_MODE); ! mpfr_set (op->value.complex.i, im, GFC_RND_MODE); ! mpfr_clear (re); ! mpfr_clear (im); ! mpfr_clear (mod); ! mpfr_clear (a); } --- 851,872 ---- static void complex_reciprocal (gfc_expr *op) { ! mpfr_t mod, tmp; gfc_set_model (op->value.complex.r); mpfr_init (mod); ! mpfr_init (tmp); mpfr_mul (mod, op->value.complex.r, op->value.complex.r, GFC_RND_MODE); ! mpfr_mul (tmp, op->value.complex.i, op->value.complex.i, GFC_RND_MODE); ! mpfr_add (mod, mod, tmp, GFC_RND_MODE); ! mpfr_div (op->value.complex.r, op->value.complex.r, mod, GFC_RND_MODE); ! mpfr_neg (op->value.complex.i, op->value.complex.i, GFC_RND_MODE); ! mpfr_div (op->value.complex.i, op->value.complex.i, mod, GFC_RND_MODE); ! mpfr_clears (tmp, mod, NULL); } *************** complex_pow (gfc_expr *result, gfc_expr *** 917,924 **** mpfr_set (x_r, base->value.complex.r, GFC_RND_MODE); mpfr_set (x_i, base->value.complex.i, GFC_RND_MODE); ! /* Macro for complex multiplication. We have to take care that ! res_r/res_i and a_r/a_i can (and will) be the same variable. */ #define CMULT(res_r,res_i,a_r,a_i,b_r,b_i) \ mpfr_mul (re, a_r, b_r, GFC_RND_MODE), \ mpfr_mul (tmp, a_i, b_i, GFC_RND_MODE), \ --- 898,905 ---- mpfr_set (x_r, base->value.complex.r, GFC_RND_MODE); mpfr_set (x_i, base->value.complex.i, GFC_RND_MODE); ! /* Macro for complex multiplication. We have to take care that ! res_r/res_i and a_r/a_i can (and will) be the same variable. */ #define CMULT(res_r,res_i,a_r,a_i,b_r,b_i) \ mpfr_mul (re, a_r, b_r, GFC_RND_MODE), \ mpfr_mul (tmp, a_i, b_i, GFC_RND_MODE), \ *************** complex_pow (gfc_expr *result, gfc_expr *** 947,957 **** #undef res_i #undef CMULT ! mpfr_clear (x_r); ! mpfr_clear (x_i); ! mpfr_clear (tmp); ! mpfr_clear (re); ! mpfr_clear (im); } --- 928,934 ---- #undef res_i #undef CMULT ! mpfr_clears (x_r, x_i, tmp, re, im, NULL); } *************** gfc_arith_concat (gfc_expr *op1, gfc_exp *** 1097,1115 **** gfc_expr *result; int len; ! result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind, &op1->where); len = op1->value.character.length + op2->value.character.length; ! result->value.character.string = gfc_getmem (len + 1); result->value.character.length = len; memcpy (result->value.character.string, op1->value.character.string, ! op1->value.character.length); ! memcpy (result->value.character.string + op1->value.character.length, ! op2->value.character.string, op2->value.character.length); result->value.character.string[len] = '\0'; --- 1074,1094 ---- gfc_expr *result; int len; ! gcc_assert (op1->ts.kind == op2->ts.kind); ! result = gfc_constant_result (BT_CHARACTER, op1->ts.kind, &op1->where); len = op1->value.character.length + op2->value.character.length; ! result->value.character.string = gfc_get_wide_string (len + 1); result->value.character.length = len; memcpy (result->value.character.string, op1->value.character.string, ! op1->value.character.length * sizeof (gfc_char_t)); ! memcpy (&result->value.character.string[op1->value.character.length], ! op2->value.character.string, ! op2->value.character.length * sizeof (gfc_char_t)); result->value.character.string[len] = '\0'; *************** gfc_arith_concat (gfc_expr *op1, gfc_exp *** 1119,1125 **** } /* Comparison between real values; returns 0 if (op1 .op. op2) is true. ! This function mimics mpr_cmp but takes NaN into account. */ static int compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) --- 1098,1104 ---- } /* Comparison between real values; returns 0 if (op1 .op. op2) is true. ! This function mimics mpfr_cmp but takes NaN into account. */ static int compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) *************** gfc_compare_expr (gfc_expr *op1, gfc_exp *** 1186,1192 **** /* Compare a pair of complex numbers. Naturally, this is only for ! equality and nonequality. */ static int compare_complex (gfc_expr *op1, gfc_expr *op2) --- 1165,1171 ---- /* Compare a pair of complex numbers. Naturally, this is only for ! equality and inequality. */ static int compare_complex (gfc_expr *op1, gfc_expr *op2) *************** compare_complex (gfc_expr *op1, gfc_expr *** 1203,1221 **** int gfc_compare_string (gfc_expr *a, gfc_expr *b) { ! int len, alen, blen, i, ac, bc; alen = a->value.character.length; blen = b->value.character.length; ! len = (alen > blen) ? alen : blen; 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 (ac < bc) return -1; --- 1182,1199 ---- int gfc_compare_string (gfc_expr *a, gfc_expr *b) { ! int len, alen, blen, i; ! gfc_char_t ac, bc; alen = a->value.character.length; blen = b->value.character.length; ! len = MAX(alen, blen); for (i = 0; i < len; i++) { ! ac = ((i < alen) ? a->value.character.string[i] : ' '); ! bc = ((i < blen) ? b->value.character.string[i] : ' '); if (ac < bc) return -1; *************** gfc_compare_string (gfc_expr *a, gfc_exp *** 1224,1230 **** --- 1202,1240 ---- } /* Strings are equal */ + return 0; + } + + int + gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive) + { + int len, alen, blen, i; + gfc_char_t ac, bc; + + alen = a->value.character.length; + blen = strlen (b); + + len = MAX(alen, blen); + + for (i = 0; i < len; i++) + { + ac = ((i < alen) ? a->value.character.string[i] : ' '); + bc = ((i < blen) ? b[i] : ' '); + + if (!case_sensitive) + { + ac = TOLOWER (ac); + bc = TOLOWER (bc); + } + + if (ac < bc) + return -1; + if (ac > bc) + return 1; + } + + /* Strings are equal */ return 0; } *************** eval_f; *** 1548,1554 **** operands are array constructors. */ static gfc_expr * ! eval_intrinsic (gfc_intrinsic_op operator, eval_f eval, gfc_expr *op1, gfc_expr *op2) { gfc_expr temp, *result; --- 1558,1564 ---- operands are array constructors. */ static gfc_expr * ! eval_intrinsic (gfc_intrinsic_op op, eval_f eval, gfc_expr *op1, gfc_expr *op2) { gfc_expr temp, *result; *************** eval_intrinsic (gfc_intrinsic_op operato *** 1557,1563 **** gfc_clear_ts (&temp.ts); ! switch (operator) { /* Logical unary */ case INTRINSIC_NOT: --- 1567,1573 ---- gfc_clear_ts (&temp.ts); ! switch (op) { /* Logical unary */ case INTRINSIC_NOT: *************** eval_intrinsic (gfc_intrinsic_op operato *** 1623,1628 **** --- 1633,1643 ---- unary = 0; temp.ts.type = BT_LOGICAL; temp.ts.kind = gfc_default_logical_kind; + + /* If kind mismatch, exit and we'll error out later. */ + if (op1->ts.kind != op2->ts.kind) + goto runtime; + break; } *************** eval_intrinsic (gfc_intrinsic_op operato *** 1641,1659 **** temp.expr_type = EXPR_OP; gfc_clear_ts (&temp.ts); ! temp.value.op.operator = operator; temp.value.op.op1 = op1; temp.value.op.op2 = op2; gfc_type_convert_binary (&temp); ! if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE ! || operator == INTRINSIC_GE || operator == INTRINSIC_GT ! || operator == INTRINSIC_LE || operator == INTRINSIC_LT ! || operator == INTRINSIC_EQ_OS || operator == INTRINSIC_NE_OS ! || operator == INTRINSIC_GE_OS || operator == INTRINSIC_GT_OS ! || operator == INTRINSIC_LE_OS || operator == INTRINSIC_LT_OS) { temp.ts.type = BT_LOGICAL; temp.ts.kind = gfc_default_logical_kind; --- 1656,1674 ---- temp.expr_type = EXPR_OP; gfc_clear_ts (&temp.ts); ! temp.value.op.op = op; temp.value.op.op1 = op1; temp.value.op.op2 = op2; gfc_type_convert_binary (&temp); ! if (op == INTRINSIC_EQ || op == INTRINSIC_NE ! || op == INTRINSIC_GE || op == INTRINSIC_GT ! || op == INTRINSIC_LE || op == INTRINSIC_LT ! || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS ! || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS ! || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS) { temp.ts.type = BT_LOGICAL; temp.ts.kind = gfc_default_logical_kind; *************** eval_intrinsic (gfc_intrinsic_op operato *** 1664,1674 **** /* Character binary */ case INTRINSIC_CONCAT: ! if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER) goto runtime; temp.ts.type = BT_CHARACTER; ! temp.ts.kind = gfc_default_character_kind; unary = 0; break; --- 1679,1690 ---- /* Character binary */ case INTRINSIC_CONCAT: ! if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER ! || op1->ts.kind != op2->ts.kind) goto runtime; temp.ts.type = BT_CHARACTER; ! temp.ts.kind = op1->ts.kind; unary = 0; break; *************** eval_intrinsic (gfc_intrinsic_op operato *** 1680,1686 **** } /* Try to combine the operators. */ ! if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER) goto runtime; if (op1->expr_type != EXPR_CONSTANT --- 1696,1702 ---- } /* Try to combine the operators. */ ! if (op == INTRINSIC_POWER && op2->ts.type != BT_INTEGER) goto runtime; if (op1->expr_type != EXPR_CONSTANT *************** runtime: *** 1715,1721 **** result->ts = temp.ts; result->expr_type = EXPR_OP; ! result->value.op.operator = operator; result->value.op.op1 = op1; result->value.op.op2 = op2; --- 1731,1737 ---- result->ts = temp.ts; result->expr_type = EXPR_OP; ! result->value.op.op = op; result->value.op.op1 = op1; result->value.op.op2 = op2; *************** runtime: *** 1729,1740 **** /* Modify type of expression for zero size array. */ static gfc_expr * ! eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op) { if (op == NULL) gfc_internal_error ("eval_type_intrinsic0(): op NULL"); ! switch (operator) { case INTRINSIC_GE: case INTRINSIC_GE_OS: --- 1745,1756 ---- /* Modify type of expression for zero size array. */ static gfc_expr * ! eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op) { if (op == NULL) gfc_internal_error ("eval_type_intrinsic0(): op NULL"); ! switch (iop) { case INTRINSIC_GE: case INTRINSIC_GE_OS: *************** reduce_binary0 (gfc_expr *op1, gfc_expr *** 1796,1802 **** static gfc_expr * ! eval_intrinsic_f2 (gfc_intrinsic_op operator, arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2) { --- 1812,1818 ---- static gfc_expr * ! eval_intrinsic_f2 (gfc_intrinsic_op op, arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2) { *************** eval_intrinsic_f2 (gfc_intrinsic_op oper *** 1806,1827 **** if (op2 == NULL) { if (gfc_zero_size_array (op1)) ! return eval_type_intrinsic0 (operator, op1); } else { result = reduce_binary0 (op1, op2); if (result != NULL) ! return eval_type_intrinsic0 (operator, result); } f.f2 = eval; ! return eval_intrinsic (operator, f, op1, op2); } static gfc_expr * ! eval_intrinsic_f3 (gfc_intrinsic_op operator, arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2) { --- 1822,1843 ---- if (op2 == NULL) { if (gfc_zero_size_array (op1)) ! return eval_type_intrinsic0 (op, op1); } else { result = reduce_binary0 (op1, op2); if (result != NULL) ! return eval_type_intrinsic0 (op, result); } f.f2 = eval; ! return eval_intrinsic (op, f, op1, op2); } static gfc_expr * ! eval_intrinsic_f3 (gfc_intrinsic_op op, arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *op1, gfc_expr *op2) { *************** eval_intrinsic_f3 (gfc_intrinsic_op oper *** 1830,1839 **** result = reduce_binary0 (op1, op2); if (result != NULL) ! return eval_type_intrinsic0(operator, result); f.f3 = eval; ! return eval_intrinsic (operator, f, op1, op2); } --- 1846,1855 ---- result = reduce_binary0 (op1, op2); if (result != NULL) ! return eval_type_intrinsic0(op, result); f.f3 = eval; ! return eval_intrinsic (op, f, op1, op2); } *************** arith_error (arith rc, gfc_typespec *fro *** 2050,2060 **** gfc_typename (from), gfc_typename (to), where); break; case ARITH_UNDERFLOW: ! gfc_error ("Arithmetic underflow converting %s to %s at %L", gfc_typename (from), gfc_typename (to), where); break; case ARITH_NAN: ! gfc_error ("Arithmetic NaN converting %s to %s at %L", gfc_typename (from), gfc_typename (to), where); break; case ARITH_DIV0: --- 2066,2078 ---- gfc_typename (from), gfc_typename (to), where); break; case ARITH_UNDERFLOW: ! gfc_error ("Arithmetic underflow converting %s to %s at %L. This check " ! "can be disabled with the option -fno-range-check", gfc_typename (from), gfc_typename (to), where); break; case ARITH_NAN: ! gfc_error ("Arithmetic NaN converting %s to %s at %L. This check " ! "can be disabled with the option -fno-range-check", gfc_typename (from), gfc_typename (to), where); break; case ARITH_DIV0: *************** arith_error (arith rc, gfc_typespec *fro *** 2074,2080 **** gfc_internal_error ("gfc_arith_error(): Bad error code"); } ! /* TODO: Do something about the error, ie, throw exception, return NaN, etc. */ } --- 2092,2098 ---- gfc_internal_error ("gfc_arith_error(): Bad error code"); } ! /* TODO: Do something about the error, i.e., throw exception, return NaN, etc. */ } *************** gfc_real2int (gfc_expr *src, int kind) *** 2166,2172 **** result = gfc_constant_result (BT_INTEGER, kind, &src->where); ! gfc_mpfr_to_mpz (result->value.integer, src->value.real); if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) { --- 2184,2190 ---- result = gfc_constant_result (BT_INTEGER, kind, &src->where); ! gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where); if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) { *************** gfc_complex2int (gfc_expr *src, int kind *** 2252,2258 **** result = gfc_constant_result (BT_INTEGER, kind, &src->where); ! gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r); if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) { --- 2270,2276 ---- result = gfc_constant_result (BT_INTEGER, kind, &src->where); ! gfc_mpfr_to_mpz (result->value.integer, src->value.complex.r, &src->where); if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) { *************** hollerith2representation (gfc_expr *resu *** 2403,2411 **** &src->where, gfc_typename(&result->ts)); } ! result->representation.string = gfc_getmem (result_len + 1); memcpy (result->representation.string, src->representation.string, ! MIN (result_len, src_len)); if (src_len < result_len) memset (&result->representation.string[src_len], ' ', result_len - src_len); --- 2421,2429 ---- &src->where, gfc_typename(&result->ts)); } ! result->representation.string = XCNEWVEC (char, result_len + 1); memcpy (result->representation.string, src->representation.string, ! MIN (result_len, src_len)); if (src_len < result_len) memset (&result->representation.string[src_len], ' ', result_len - src_len); *************** gfc_hollerith2int (gfc_expr *src, int ki *** 2429,2436 **** result->where = src->where; hollerith2representation (result, src); ! gfc_interpret_integer(kind, (unsigned char *) result->representation.string, ! result->representation.length, result->value.integer); return result; } --- 2447,2454 ---- result->where = src->where; hollerith2representation (result, src); ! gfc_interpret_integer (kind, (unsigned char *) result->representation.string, ! result->representation.length, result->value.integer); return result; } *************** gfc_hollerith2real (gfc_expr *src, int k *** 2453,2460 **** result->where = src->where; hollerith2representation (result, src); ! gfc_interpret_float(kind, (unsigned char *) result->representation.string, ! result->representation.length, result->value.real); return result; } --- 2471,2478 ---- result->where = src->where; hollerith2representation (result, src); ! gfc_interpret_float (kind, (unsigned char *) result->representation.string, ! result->representation.length, result->value.real); return result; } *************** gfc_hollerith2complex (gfc_expr *src, in *** 2477,2485 **** result->where = src->where; hollerith2representation (result, src); ! gfc_interpret_complex(kind, (unsigned char *) result->representation.string, ! result->representation.length, result->value.complex.r, ! result->value.complex.i); return result; } --- 2495,2503 ---- result->where = src->where; hollerith2representation (result, src); ! gfc_interpret_complex (kind, (unsigned char *) result->representation.string, ! result->representation.length, result->value.complex.r, ! result->value.complex.i); return result; } *************** gfc_hollerith2character (gfc_expr *src, *** 2496,2503 **** result->ts.type = BT_CHARACTER; result->ts.kind = kind; - result->value.character.string = result->representation.string; result->value.character.length = result->representation.length; return result; } --- 2514,2522 ---- result->ts.type = BT_CHARACTER; result->ts.kind = kind; result->value.character.length = result->representation.length; + result->value.character.string + = gfc_char_to_widechar (result->representation.string); return result; } *************** gfc_hollerith2logical (gfc_expr *src, in *** 2520,2527 **** result->where = src->where; hollerith2representation (result, src); ! gfc_interpret_logical(kind, (unsigned char *) result->representation.string, ! result->representation.length, &result->value.logical); return result; } --- 2539,2546 ---- result->where = src->where; hollerith2representation (result, src); ! gfc_interpret_logical (kind, (unsigned char *) result->representation.string, ! result->representation.length, &result->value.logical); return result; } diff -Nrcpad gcc-4.3.3/gcc/fortran/arith.h gcc-4.4.0/gcc/fortran/arith.h *** gcc-4.3.3/gcc/fortran/arith.h Wed Dec 5 13:42:32 2007 --- gcc-4.4.0/gcc/fortran/arith.h Fri Oct 31 04:45:28 2008 *************** *** 1,5 **** /* Compiler arithmetic header. ! Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Steven Bosscher --- 1,5 ---- /* Compiler arithmetic header. ! Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Steven Bosscher *************** along with GCC; see the file COPYING3. *** 27,33 **** /* MPFR also does not have the conversion of a mpfr_t to a mpz_t, so declare a function for this as well. */ ! void gfc_mpfr_to_mpz (mpz_t, mpfr_t); void gfc_set_model_kind (int); void gfc_set_model (mpfr_t); --- 27,33 ---- /* MPFR also does not have the conversion of a mpfr_t to a mpz_t, so declare a function for this as well. */ ! void gfc_mpfr_to_mpz (mpz_t, mpfr_t, locus *); void gfc_set_model_kind (int); void gfc_set_model (mpfr_t); *************** arith gfc_range_check (gfc_expr *); *** 40,45 **** --- 40,47 ---- int gfc_compare_expr (gfc_expr *, gfc_expr *, gfc_intrinsic_op); int gfc_compare_string (gfc_expr *, gfc_expr *); + int gfc_compare_with_Cstring (gfc_expr *, const char *, bool); + /* Constant folding for gfc_expr trees. */ gfc_expr *gfc_parentheses (gfc_expr * op); diff -Nrcpad gcc-4.3.3/gcc/fortran/array.c gcc-4.4.0/gcc/fortran/array.c *** gcc-4.3.3/gcc/fortran/array.c Tue Feb 5 13:33:35 2008 --- gcc-4.4.0/gcc/fortran/array.c Sat Feb 21 22:25:06 2009 *************** *** 1,5 **** /* Array things ! Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught --- 1,5 ---- /* Array things ! Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Andy Vaught *************** along with GCC; see the file COPYING3. *** 24,36 **** #include "gfortran.h" #include "match.h" - /* This parameter is the size of the largest array constructor that we - will expand to an array constructor without iterators. - Constructors larger than this will remain in the iterator form. */ - - #define GFC_MAX_AC_EXPAND 65535 - - /**************** Array reference matching subroutines *****************/ /* Copy an array reference structure. */ --- 24,29 ---- *************** gfc_free_array_spec (gfc_array_spec *as) *** 208,214 **** /* Take an array bound, resolves the expression, that make up the shape and check associated constraints. */ ! static try resolve_array_bound (gfc_expr *e, int check_constant) { if (e == NULL) --- 201,207 ---- /* Take an array bound, resolves the expression, that make up the shape and check associated constraints. */ ! static gfc_try resolve_array_bound (gfc_expr *e, int check_constant) { if (e == NULL) *************** resolve_array_bound (gfc_expr *e, int ch *** 232,238 **** /* Takes an array specification, resolves the expressions that make up the shape and make sure everything is integral. */ ! try gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) { gfc_expr *e; --- 225,231 ---- /* Takes an array specification, resolves the expressions that make up the shape and make sure everything is integral. */ ! gfc_try gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) { gfc_expr *e; *************** match_array_element_spec (gfc_array_spec *** 314,319 **** --- 307,314 ---- gfc_error ("Expected expression in array specification at %C"); if (m != MATCH_YES) return AS_UNKNOWN; + if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE) + return AS_UNKNOWN; if (gfc_match_char (':') == MATCH_NO) { *************** match_array_element_spec (gfc_array_spec *** 332,337 **** --- 327,334 ---- return AS_UNKNOWN; if (m == MATCH_NO) return AS_ASSUMED_SHAPE; + if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE) + return AS_UNKNOWN; return AS_EXPLICIT; } *************** gfc_match_array_spec (gfc_array_spec **a *** 437,442 **** --- 434,445 ---- goto cleanup; } + if (as->rank >= 7 + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array " + "specification at %C with more than 7 dimensions") + == FAILURE) + goto cleanup; + as->rank++; } *************** cleanup: *** 463,469 **** have that array specification. The error locus is needed in case something goes wrong. On failure, the caller must free the spec. */ ! try gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) { if (as == NULL) --- 466,472 ---- have that array specification. The error locus is needed in case something goes wrong. On failure, the caller must free the spec. */ ! gfc_try gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) { if (as == NULL) *************** gfc_start_constructor (bt type, int kind *** 586,592 **** node onto the constructor. */ void ! gfc_append_constructor (gfc_expr *base, gfc_expr *new) { gfc_constructor *c; --- 589,595 ---- node onto the constructor. */ void ! gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr) { gfc_constructor *c; *************** gfc_append_constructor (gfc_expr *base, *** 602,610 **** c = c->next; } ! c->expr = new; ! if (new->ts.type != base->ts.type || new->ts.kind != base->ts.kind) gfc_internal_error ("gfc_append_constructor(): New node has wrong kind"); } --- 605,613 ---- c = c->next; } ! c->expr = new_expr; ! if (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind) gfc_internal_error ("gfc_append_constructor(): New node has wrong kind"); } *************** gfc_get_constructor (void) *** 672,678 **** { gfc_constructor *c; ! c = gfc_getmem (sizeof(gfc_constructor)); c->expr = NULL; c->iterator = NULL; c->next = NULL; --- 675,681 ---- { gfc_constructor *c; ! c = XCNEW (gfc_constructor); c->expr = NULL; c->iterator = NULL; c->next = NULL; *************** static match match_array_cons_element (g *** 749,755 **** static match match_array_list (gfc_constructor **result) { ! gfc_constructor *p, *head, *tail, *new; gfc_iterator iter; locus old_loc; gfc_expr *e; --- 752,758 ---- static match match_array_list (gfc_constructor **result) { ! gfc_constructor *p, *head, *tail, *new_cons; gfc_iterator iter; locus old_loc; gfc_expr *e; *************** match_array_list (gfc_constructor **resu *** 784,790 **** if (m == MATCH_ERROR) goto cleanup; ! m = match_array_cons_element (&new); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) --- 787,793 ---- if (m == MATCH_ERROR) goto cleanup; ! m = match_array_cons_element (&new_cons); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) *************** match_array_list (gfc_constructor **resu *** 795,802 **** goto cleanup; /* Could be a complex constant */ } ! tail->next = new; ! tail = new; if (gfc_match_char (',') != MATCH_YES) { --- 798,805 ---- goto cleanup; /* Could be a complex constant */ } ! tail->next = new_cons; ! tail = new_cons; if (gfc_match_char (',') != MATCH_YES) { *************** match_array_cons_element (gfc_constructo *** 875,885 **** match gfc_match_array_constructor (gfc_expr **result) { ! gfc_constructor *head, *tail, *new; gfc_expr *expr; locus where; match m; const char *end_delim; if (gfc_match (" (/") == MATCH_NO) { --- 878,890 ---- match gfc_match_array_constructor (gfc_expr **result) { ! gfc_constructor *head, *tail, *new_cons; gfc_expr *expr; + gfc_typespec ts; locus where; match m; const char *end_delim; + bool seen_ts; if (gfc_match (" (/") == MATCH_NO) { *************** gfc_match_array_constructor (gfc_expr ** *** 898,924 **** where = gfc_current_locus; head = tail = NULL; if (gfc_match (end_delim) == MATCH_YES) { ! gfc_error ("Empty array constructor at %C is not allowed"); ! goto cleanup; } for (;;) { ! m = match_array_cons_element (&new); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; if (head == NULL) ! head = new; else ! tail->next = new; ! tail = new; if (gfc_match_char (',') == MATCH_NO) break; --- 903,951 ---- where = gfc_current_locus; head = tail = NULL; + seen_ts = false; + + /* Try to match an optional "type-spec ::" */ + if (gfc_match_type_spec (&ts, 0) == MATCH_YES) + { + seen_ts = (gfc_match (" ::") == MATCH_YES); + + if (seen_ts) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor " + "including type specification at %C") == FAILURE) + goto cleanup; + } + } + + if (! seen_ts) + gfc_current_locus = where; if (gfc_match (end_delim) == MATCH_YES) { ! if (seen_ts) ! goto done; ! else ! { ! gfc_error ("Empty array constructor at %C is not allowed"); ! goto cleanup; ! } } for (;;) { ! m = match_array_cons_element (&new_cons); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; if (head == NULL) ! head = new_cons; else ! tail->next = new_cons; ! tail = new_cons; if (gfc_match_char (',') == MATCH_NO) break; *************** gfc_match_array_constructor (gfc_expr ** *** 927,932 **** --- 954,960 ---- if (gfc_match (end_delim) == MATCH_NO) goto syntax; + done: expr = gfc_get_expr (); expr->expr_type = EXPR_ARRAY; *************** gfc_match_array_constructor (gfc_expr ** *** 934,939 **** --- 962,975 ---- expr->value.constructor = head; /* Size must be calculated at resolution time. */ + if (seen_ts) + expr->ts = ts; + else + expr->ts.type = BT_UNKNOWN; + + if (expr->ts.cl) + expr->ts.cl->length_from_typespec = seen_ts; + expr->where = where; expr->rank = 1; *************** static enum *** 964,970 **** cons_state; static int ! check_element_type (gfc_expr *expr) { if (cons_state == CONS_BAD) return 0; /* Suppress further errors */ --- 1000,1006 ---- cons_state; static int ! check_element_type (gfc_expr *expr, bool convert) { if (cons_state == CONS_BAD) return 0; /* Suppress further errors */ *************** check_element_type (gfc_expr *expr) *** 985,990 **** --- 1021,1029 ---- if (gfc_compare_types (&constructor_ts, &expr->ts)) return 0; + if (convert) + return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1; + gfc_error ("Element in %s array constructor at %L is %s", gfc_typename (&constructor_ts), &expr->where, gfc_typename (&expr->ts)); *************** check_element_type (gfc_expr *expr) *** 996,1003 **** /* Recursive work function for gfc_check_constructor_type(). */ ! static try ! check_constructor_type (gfc_constructor *c) { gfc_expr *e; --- 1035,1042 ---- /* Recursive work function for gfc_check_constructor_type(). */ ! static gfc_try ! check_constructor_type (gfc_constructor *c, bool convert) { gfc_expr *e; *************** check_constructor_type (gfc_constructor *** 1007,1019 **** if (e->expr_type == EXPR_ARRAY) { ! if (check_constructor_type (e->value.constructor) == FAILURE) return FAILURE; continue; } ! if (check_element_type (e)) return FAILURE; } --- 1046,1058 ---- if (e->expr_type == EXPR_ARRAY) { ! if (check_constructor_type (e->value.constructor, convert) == FAILURE) return FAILURE; continue; } ! if (check_element_type (e, convert)) return FAILURE; } *************** check_constructor_type (gfc_constructor *** 1024,1038 **** /* Check that all elements of an array constructor are the same type. On FAILURE, an error has been generated. */ ! try gfc_check_constructor_type (gfc_expr *e) { ! try t; ! cons_state = CONS_START; ! gfc_clear_ts (&constructor_ts); ! t = check_constructor_type (e->value.constructor); if (t == SUCCESS && e->ts.type == BT_UNKNOWN) e->ts = constructor_ts; --- 1063,1087 ---- /* Check that all elements of an array constructor are the same type. On FAILURE, an error has been generated. */ ! gfc_try gfc_check_constructor_type (gfc_expr *e) { ! gfc_try t; ! if (e->ts.type != BT_UNKNOWN) ! { ! cons_state = CONS_GOOD; ! constructor_ts = e->ts; ! } ! else ! { ! cons_state = CONS_START; ! gfc_clear_ts (&constructor_ts); ! } ! /* If e->ts.type != BT_UNKNOWN, the array constructor included a ! typespec, and we will now convert the values on the fly. */ ! t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN); if (t == SUCCESS && e->ts.type == BT_UNKNOWN) e->ts = constructor_ts; *************** cons_stack; *** 1050,1061 **** static cons_stack *base; ! static try check_constructor (gfc_constructor *, try (*) (gfc_expr *)); /* Check an EXPR_VARIABLE expression in a constructor to make sure that that variable is an iteration variables. */ ! try gfc_check_iter_variable (gfc_expr *expr) { gfc_symbol *sym; --- 1099,1110 ---- static cons_stack *base; ! static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *)); /* Check an EXPR_VARIABLE expression in a constructor to make sure that that variable is an iteration variables. */ ! gfc_try gfc_check_iter_variable (gfc_expr *expr) { gfc_symbol *sym; *************** gfc_check_iter_variable (gfc_expr *expr) *** 1075,1086 **** to calling the check function for each expression in the constructor, giving variables with the names of iterators a pass. */ ! static try ! check_constructor (gfc_constructor *c, try (*check_function) (gfc_expr *)) { cons_stack element; gfc_expr *e; ! try t; for (; c; c = c->next) { --- 1124,1135 ---- to calling the check function for each expression in the constructor, giving variables with the names of iterators a pass. */ ! static gfc_try ! check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *)) { cons_stack element; gfc_expr *e; ! gfc_try t; for (; c; c = c->next) { *************** check_constructor (gfc_constructor *c, t *** 1113,1123 **** expression -- specification, restricted, or initialization as determined by the check_function. */ ! try ! gfc_check_constructor (gfc_expr *expr, try (*check_function) (gfc_expr *)) { cons_stack *base_save; ! try t; base_save = base; base = NULL; --- 1162,1172 ---- expression -- specification, restricted, or initialization as determined by the check_function. */ ! gfc_try ! gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *)) { cons_stack *base_save; ! gfc_try t; base_save = base; base = NULL; *************** typedef struct *** 1145,1163 **** gfc_component *component; mpz_t *repeat; ! try (*expand_work_function) (gfc_expr *); } expand_info; static expand_info current_expand; ! static try expand_constructor (gfc_constructor *); /* Work function that counts the number of elements present in a constructor. */ ! static try count_elements (gfc_expr *e) { mpz_t result; --- 1194,1212 ---- gfc_component *component; mpz_t *repeat; ! gfc_try (*expand_work_function) (gfc_expr *); } expand_info; static expand_info current_expand; ! static gfc_try expand_constructor (gfc_constructor *); /* Work function that counts the number of elements present in a constructor. */ ! static gfc_try count_elements (gfc_expr *e) { mpz_t result; *************** count_elements (gfc_expr *e) *** 1184,1190 **** /* Work function that extracts a particular element from an array constructor, freeing the rest. */ ! static try extract_element (gfc_expr *e) { --- 1233,1239 ---- /* Work function that extracts a particular element from an array constructor, freeing the rest. */ ! static gfc_try extract_element (gfc_expr *e) { *************** extract_element (gfc_expr *e) *** 1207,1213 **** /* Work function that constructs a new constructor out of the old one, stringing new elements together. */ ! static try expand (gfc_expr *e) { if (current_expand.new_head == NULL) --- 1256,1262 ---- /* Work function that constructs a new constructor out of the old one, stringing new elements together. */ ! static gfc_try expand (gfc_expr *e) { if (current_expand.new_head == NULL) *************** gfc_simplify_iterator_var (gfc_expr *e) *** 1255,1261 **** /* Expand an expression with that is inside of a constructor, recursing into other constructors if present. */ ! static try expand_expr (gfc_expr *e) { if (e->expr_type == EXPR_ARRAY) --- 1304,1310 ---- /* Expand an expression with that is inside of a constructor, recursing into other constructors if present. */ ! static gfc_try expand_expr (gfc_expr *e) { if (e->expr_type == EXPR_ARRAY) *************** expand_expr (gfc_expr *e) *** 1273,1285 **** } ! static try expand_iterator (gfc_constructor *c) { gfc_expr *start, *end, *step; iterator_stack frame; mpz_t trip; ! try t; end = step = NULL; --- 1322,1334 ---- } ! static gfc_try expand_iterator (gfc_constructor *c) { gfc_expr *start, *end, *step; iterator_stack frame; mpz_t trip; ! gfc_try t; end = step = NULL; *************** cleanup: *** 1357,1363 **** expressions. The work function needs to either save or free the passed expression. */ ! static try expand_constructor (gfc_constructor *c) { gfc_expr *e; --- 1406,1412 ---- expressions. The work function needs to either save or free the passed expression. */ ! static gfc_try expand_constructor (gfc_constructor *c) { gfc_expr *e; *************** expand_constructor (gfc_constructor *c) *** 1400,1413 **** /* Top level subroutine for expanding constructors. We only expand constructor if they are small enough. */ ! try gfc_expand_constructor (gfc_expr *e) { expand_info expand_save; gfc_expr *f; ! try rc; ! f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND); if (f != NULL) { gfc_free_expr (f); --- 1449,1462 ---- /* Top level subroutine for expanding constructors. We only expand constructor if they are small enough. */ ! gfc_try gfc_expand_constructor (gfc_expr *e) { expand_info expand_save; gfc_expr *f; ! gfc_try rc; ! f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor); if (f != NULL) { gfc_free_expr (f); *************** done: *** 1444,1450 **** constant, after removal of any iteration variables. We return FAILURE if not so. */ ! static try constant_element (gfc_expr *e) { int rv; --- 1493,1499 ---- constant, after removal of any iteration variables. We return FAILURE if not so. */ ! static gfc_try constant_element (gfc_expr *e) { int rv; *************** int *** 1466,1472 **** gfc_constant_ac (gfc_expr *e) { expand_info expand_save; ! try rc; iter_stack = NULL; expand_save = current_expand; --- 1515,1521 ---- gfc_constant_ac (gfc_expr *e) { expand_info expand_save; ! gfc_try rc; iter_stack = NULL; expand_save = current_expand; *************** gfc_expanded_ac (gfc_expr *e) *** 1504,1513 **** /* Recursive array list resolution function. All of the elements must be of the same type. */ ! static try resolve_array_list (gfc_constructor *p) { ! try t; t = SUCCESS; --- 1553,1562 ---- /* Recursive array list resolution function. All of the elements must be of the same type. */ ! static gfc_try resolve_array_list (gfc_constructor *p) { ! gfc_try t; t = SUCCESS; *************** resolve_array_list (gfc_constructor *p) *** 1524,1544 **** return t; } ! /* Resolve character array constructor. If it is a constant character array and ! 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; gcc_assert (expr->expr_type == EXPR_ARRAY); gcc_assert (expr->ts.type == BT_CHARACTER); - max_length = -1; - if (expr->ts.cl == NULL) { for (p = expr->value.constructor; p; p = p->next) --- 1573,1592 ---- return t; } ! /* Resolve character array constructor. If it has a specified constant character ! length, pad/truncate the elements here; if the length is not specified and ! all elements are of compile-time known length, emit an error as this is ! invalid. */ ! gfc_try gfc_resolve_character_array_constructor (gfc_expr *expr) { gfc_constructor *p; ! int found_length; gcc_assert (expr->expr_type == EXPR_ARRAY); gcc_assert (expr->ts.type == BT_CHARACTER); if (expr->ts.cl == NULL) { for (p = expr->value.constructor; p; p = p->next) *************** gfc_resolve_character_array_constructor *** 1557,1570 **** 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 --- 1605,1620 ---- got_charlen: + found_length = -1; + if (expr->ts.cl->length == NULL) { ! /* Check that all constant string elements have the same length until ! we reach the end or find a variable-length one. */ for (p = expr->value.constructor; p; p = p->next) { + int current_length = -1; gfc_ref *ref; for (ref = p->expr->ref; ref; ref = ref->next) if (ref->type == REF_SUBSTRING *************** got_charlen: *** 1573,1622 **** break; if (p->expr->expr_type == EXPR_CONSTANT) ! max_length = MAX (p->expr->value.character.length, max_length); else if (ref) { long j; j = mpz_get_ui (ref->u.ss.end->value.integer) - mpz_get_ui (ref->u.ss.start->value.integer) + 1; ! max_length = MAX ((int) j, max_length); } else if (p->expr->ts.cl && p->expr->ts.cl->length && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT) { long j; j = mpz_get_si (p->expr->ts.cl->length->value.integer); ! max_length = MAX ((int) j, max_length); } else ! return; ! } ! if (max_length != -1) ! { ! /* Update the character length of the array constructor. */ ! 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, true); } } } /* Resolve all of the expressions in an array list. */ ! try gfc_resolve_array_constructor (gfc_expr *expr) { ! try t; t = resolve_array_list (expr->value.constructor); 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; } --- 1623,1725 ---- break; if (p->expr->expr_type == EXPR_CONSTANT) ! current_length = p->expr->value.character.length; else if (ref) { long j; j = mpz_get_ui (ref->u.ss.end->value.integer) - mpz_get_ui (ref->u.ss.start->value.integer) + 1; ! current_length = (int) j; } else if (p->expr->ts.cl && p->expr->ts.cl->length && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT) { long j; j = mpz_get_si (p->expr->ts.cl->length->value.integer); ! current_length = (int) j; } else ! return SUCCESS; ! gcc_assert (current_length != -1); ! ! if (found_length == -1) ! found_length = current_length; ! else if (found_length != current_length) ! { ! gfc_error ("Different CHARACTER lengths (%d/%d) in array" ! " constructor at %L", found_length, current_length, ! &p->expr->where); ! return FAILURE; ! } ! ! gcc_assert (found_length == current_length); } + + gcc_assert (found_length != -1); + + /* Update the character length of the array constructor. */ + expr->ts.cl->length = gfc_int_expr (found_length); + } + else + { + /* We've got a character length specified. It should be an integer, + otherwise an error is signalled elsewhere. */ + gcc_assert (expr->ts.cl->length); + + /* If we've got a constant character length, pad according to this. + gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets + max_length only if they pass. */ + gfc_extract_int (expr->ts.cl->length, &found_length); + + /* Now pad/truncate the elements accordingly to the specified character + length. This is ok inside this conditional, as in the case above + (without typespec) all elements are verified to have the same length + anyway. */ + if (found_length != -1) + for (p = expr->value.constructor; p; p = p->next) + if (p->expr->expr_type == EXPR_CONSTANT) + { + gfc_expr *cl = NULL; + int current_length = -1; + bool has_ts; + + if (p->expr->ts.cl && p->expr->ts.cl->length) + { + cl = p->expr->ts.cl->length; + gfc_extract_int (cl, ¤t_length); + } + + /* If gfc_extract_int above set current_length, we implicitly + know the type is BT_INTEGER and it's EXPR_CONSTANT. */ + + has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec); + + if (! cl + || (current_length != -1 && current_length < found_length)) + gfc_set_constant_character_len (found_length, p->expr, + has_ts ? -1 : found_length); + } } + + return SUCCESS; } /* Resolve all of the expressions in an array list. */ ! gfc_try gfc_resolve_array_constructor (gfc_expr *expr) { ! gfc_try t; t = resolve_array_list (expr->value.constructor); if (t == SUCCESS) t = gfc_check_constructor_type (expr); ! ! /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after ! the call to this function, so we don't need to call it here; if it was ! called twice, an error message there would be duplicated. */ return t; } *************** gfc_get_array_element (gfc_expr *array, *** 1689,1695 **** { expand_info expand_save; gfc_expr *e; ! try rc; expand_save = current_expand; current_expand.extract_n = element; --- 1792,1798 ---- { expand_info expand_save; gfc_expr *e; ! gfc_try rc; expand_save = current_expand; current_expand.extract_n = element; *************** gfc_get_array_element (gfc_expr *array, *** 1720,1726 **** /* Get the size of single dimension of an array specification. The array is guaranteed to be one dimensional. */ ! try spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result) { if (as == NULL) --- 1823,1829 ---- /* Get the size of single dimension of an array specification. The array is guaranteed to be one dimensional. */ ! gfc_try spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result) { if (as == NULL) *************** spec_dimen_size (gfc_array_spec *as, int *** 1747,1753 **** } ! try spec_size (gfc_array_spec *as, mpz_t *result) { mpz_t size; --- 1850,1856 ---- } ! gfc_try spec_size (gfc_array_spec *as, mpz_t *result) { mpz_t size; *************** spec_size (gfc_array_spec *as, mpz_t *re *** 1773,1786 **** /* Get the number of elements in an array section. */ ! static try ! ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result) { mpz_t upper, lower, stride; ! try t; if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1) ! gfc_internal_error ("ref_dimen_size(): Bad dimension"); switch (ar->dimen_type[dimen]) { --- 1876,1889 ---- /* Get the number of elements in an array section. */ ! gfc_try ! gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result) { mpz_t upper, lower, stride; ! gfc_try t; if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1) ! gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension"); switch (ar->dimen_type[dimen]) { *************** ref_dimen_size (gfc_array_ref *ar, int d *** 1854,1867 **** return t; default: ! gfc_internal_error ("ref_dimen_size(): Bad dimen_type"); } return t; } ! static try ref_size (gfc_array_ref *ar, mpz_t *result) { mpz_t size; --- 1957,1970 ---- return t; default: ! gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type"); } return t; } ! static gfc_try ref_size (gfc_array_ref *ar, mpz_t *result) { mpz_t size; *************** ref_size (gfc_array_ref *ar, mpz_t *resu *** 1871,1877 **** for (d = 0; d < ar->dimen; d++) { ! if (ref_dimen_size (ar, d, &size) == FAILURE) { mpz_clear (*result); return FAILURE; --- 1974,1980 ---- for (d = 0; d < ar->dimen; d++) { ! if (gfc_ref_dimen_size (ar, d, &size) == FAILURE) { mpz_clear (*result); return FAILURE; *************** ref_size (gfc_array_ref *ar, mpz_t *resu *** 1890,1896 **** able to return a result in the 'result' variable, FAILURE otherwise. */ ! try gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) { gfc_ref *ref; --- 1993,1999 ---- able to return a result in the 'result' variable, FAILURE otherwise. */ ! gfc_try gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) { gfc_ref *ref; *************** gfc_array_dimen_size (gfc_expr *array, i *** 1917,1923 **** if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) dimen--; ! return ref_dimen_size (&ref->u.ar, i - 1, result); } } --- 2020,2026 ---- if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) dimen--; ! return gfc_ref_dimen_size (&ref->u.ar, i - 1, result); } } *************** gfc_array_dimen_size (gfc_expr *array, i *** 1958,1976 **** array. Returns SUCCESS if this is possible, and sets the 'result' variable. Otherwise returns FAILURE. */ ! try gfc_array_size (gfc_expr *array, mpz_t *result) { expand_info expand_save; gfc_ref *ref; ! int i, flag; ! try t; switch (array->expr_type) { case EXPR_ARRAY: ! flag = gfc_suppress_error; ! gfc_suppress_error = 1; expand_save = current_expand; --- 2061,2078 ---- array. Returns SUCCESS if this is possible, and sets the 'result' variable. Otherwise returns FAILURE. */ ! gfc_try gfc_array_size (gfc_expr *array, mpz_t *result) { expand_info expand_save; gfc_ref *ref; ! int i; ! gfc_try t; switch (array->expr_type) { case EXPR_ARRAY: ! gfc_push_suppress_errors (); expand_save = current_expand; *************** gfc_array_size (gfc_expr *array, mpz_t * *** 1981,1987 **** iter_stack = NULL; t = expand_constructor (array->value.constructor); ! gfc_suppress_error = flag; if (t == FAILURE) mpz_clear (*result); --- 2083,2090 ---- iter_stack = NULL; t = expand_constructor (array->value.constructor); ! ! gfc_pop_suppress_errors (); if (t == FAILURE) mpz_clear (*result); *************** gfc_array_size (gfc_expr *array, mpz_t * *** 2023,2029 **** /* Given an array reference, return the shape of the reference in an array of mpz_t integers. */ ! try gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape) { int d; --- 2126,2132 ---- /* Given an array reference, return the shape of the reference in an array of mpz_t integers. */ ! gfc_try gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape) { int d; *************** gfc_array_ref_shape (gfc_array_ref *ar, *** 2045,2051 **** { if (ar->dimen_type[i] != DIMEN_ELEMENT) { ! if (ref_dimen_size (ar, i, &shape[d]) == FAILURE) goto cleanup; d++; } --- 2148,2154 ---- { if (ar->dimen_type[i] != DIMEN_ELEMENT) { ! if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE) goto cleanup; d++; } diff -Nrcpad gcc-4.3.3/gcc/fortran/bbt.c gcc-4.4.0/gcc/fortran/bbt.c *** gcc-4.3.3/gcc/fortran/bbt.c Wed Aug 1 16:29:36 2007 --- gcc-4.4.0/gcc/fortran/bbt.c Sat Jul 19 16:23:52 2008 *************** *** 1,5 **** /* Balanced binary trees using treaps. ! Copyright (C) 2000, 2002, 2003, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught --- 1,5 ---- /* Balanced binary trees using treaps. ! Copyright (C) 2000, 2002, 2003, 2007, 2008 Free Software Foundation, Inc. Contributed by Andy Vaught *************** rotate_right (gfc_bbt *t) *** 93,116 **** aborts if we find a duplicate key. */ static gfc_bbt * ! insert (gfc_bbt *new, gfc_bbt *t, compare_fn compare) { int c; if (t == NULL) ! return new; ! c = (*compare) (new, t); if (c < 0) { ! t->left = insert (new, t->left, compare); if (t->priority < t->left->priority) t = rotate_right (t); } else if (c > 0) { ! t->right = insert (new, t->right, compare); if (t->priority < t->right->priority) t = rotate_left (t); } --- 93,116 ---- aborts if we find a duplicate key. */ static gfc_bbt * ! insert (gfc_bbt *new_bbt, gfc_bbt *t, compare_fn compare) { int c; if (t == NULL) ! return new_bbt; ! c = (*compare) (new_bbt, t); if (c < 0) { ! t->left = insert (new_bbt, t->left, compare); if (t->priority < t->left->priority) t = rotate_right (t); } else if (c > 0) { ! t->right = insert (new_bbt, t->right, compare); if (t->priority < t->right->priority) t = rotate_left (t); } *************** insert (gfc_bbt *new, gfc_bbt *t, compar *** 126,137 **** already exists. */ void ! gfc_insert_bbt (void *root, void *new, compare_fn compare) { gfc_bbt **r, *n; r = (gfc_bbt **) root; ! n = (gfc_bbt *) new; n->priority = pseudo_random (); *r = insert (n, *r, compare); } --- 126,137 ---- already exists. */ void ! gfc_insert_bbt (void *root, void *new_node, compare_fn compare) { gfc_bbt **r, *n; r = (gfc_bbt **) root; ! n = (gfc_bbt *) new_node; n->priority = pseudo_random (); *r = insert (n, *r, compare); } diff -Nrcpad gcc-4.3.3/gcc/fortran/check.c gcc-4.4.0/gcc/fortran/check.c *** gcc-4.3.3/gcc/fortran/check.c Sun Jan 13 21:28:30 2008 --- gcc-4.4.0/gcc/fortran/check.c Fri Jan 9 23:47:55 2009 *************** *** 1,5 **** /* Check functions ! Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb --- 1,5 ---- /* Check functions ! Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb *************** along with GCC; see the file COPYING3. *** 35,41 **** /* Make sure an expression is a scalar. */ ! static try scalar_check (gfc_expr *e, int n) { if (e->rank == 0) --- 35,41 ---- /* Make sure an expression is a scalar. */ ! static gfc_try scalar_check (gfc_expr *e, int n) { if (e->rank == 0) *************** scalar_check (gfc_expr *e, int n) *** 50,56 **** /* Check the type of an expression. */ ! static try type_check (gfc_expr *e, int n, bt type) { if (e->ts.type == type) --- 50,56 ---- /* Check the type of an expression. */ ! static gfc_try type_check (gfc_expr *e, int n, bt type) { if (e->ts.type == type) *************** type_check (gfc_expr *e, int n, bt type) *** 66,72 **** /* Check that the expression is a numeric type. */ ! static try numeric_check (gfc_expr *e, int n) { if (gfc_numeric_ts (&e->ts)) --- 66,72 ---- /* Check that the expression is a numeric type. */ ! static gfc_try numeric_check (gfc_expr *e, int n) { if (gfc_numeric_ts (&e->ts)) *************** numeric_check (gfc_expr *e, int n) *** 93,99 **** /* Check that an expression is integer or real. */ ! static try int_or_real_check (gfc_expr *e, int n) { if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) --- 93,99 ---- /* Check that an expression is integer or real. */ ! static gfc_try int_or_real_check (gfc_expr *e, int n) { if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) *************** int_or_real_check (gfc_expr *e, int n) *** 110,116 **** /* Check that an expression is real or complex. */ ! static try real_or_complex_check (gfc_expr *e, int n) { if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) --- 110,116 ---- /* Check that an expression is real or complex. */ ! static gfc_try real_or_complex_check (gfc_expr *e, int n) { if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) *************** real_or_complex_check (gfc_expr *e, int *** 128,134 **** /* Check that the expression is an optional constant integer and that it specifies a valid kind for that type. */ ! static try kind_check (gfc_expr *k, int n, bt type) { int kind; --- 128,134 ---- /* Check that the expression is an optional constant integer and that it specifies a valid kind for that type. */ ! static gfc_try kind_check (gfc_expr *k, int n, bt type) { int kind; *************** kind_check (gfc_expr *k, int n, bt type) *** 164,170 **** /* Make sure the expression is a double precision real. */ ! static try double_check (gfc_expr *d, int n) { if (type_check (d, n, BT_REAL) == FAILURE) --- 164,170 ---- /* Make sure the expression is a double precision real. */ ! static gfc_try double_check (gfc_expr *d, int n) { if (type_check (d, n, BT_REAL) == FAILURE) *************** double_check (gfc_expr *d, int n) *** 184,190 **** /* Make sure the expression is a logical array. */ ! static try logical_array_check (gfc_expr *array, int n) { if (array->ts.type != BT_LOGICAL || array->rank == 0) --- 184,190 ---- /* Make sure the expression is a logical array. */ ! static gfc_try logical_array_check (gfc_expr *array, int n) { if (array->ts.type != BT_LOGICAL || array->rank == 0) *************** logical_array_check (gfc_expr *array, in *** 201,207 **** /* Make sure an expression is an array. */ ! static try array_check (gfc_expr *e, int n) { if (e->rank != 0) --- 201,207 ---- /* Make sure an expression is an array. */ ! static gfc_try array_check (gfc_expr *e, int n) { if (e->rank != 0) *************** array_check (gfc_expr *e, int n) *** 216,222 **** /* Make sure two expressions have the same type. */ ! static try same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) { if (gfc_compare_types (&e->ts, &f->ts)) --- 216,222 ---- /* Make sure two expressions have the same type. */ ! static gfc_try same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) { if (gfc_compare_types (&e->ts, &f->ts)) *************** same_type_check (gfc_expr *e, int n, gfc *** 232,238 **** /* Make sure that an expression has a certain (nonzero) rank. */ ! static try rank_check (gfc_expr *e, int n, int rank) { if (e->rank == rank) --- 232,238 ---- /* Make sure that an expression has a certain (nonzero) rank. */ ! static gfc_try rank_check (gfc_expr *e, int n, int rank) { if (e->rank == rank) *************** rank_check (gfc_expr *e, int n, int rank *** 248,254 **** /* Make sure a variable expression is not an optional dummy argument. */ ! static try nonoptional_check (gfc_expr *e, int n) { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) --- 248,254 ---- /* Make sure a variable expression is not an optional dummy argument. */ ! static gfc_try nonoptional_check (gfc_expr *e, int n) { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) *************** nonoptional_check (gfc_expr *e, int n) *** 266,272 **** /* Check that an expression has a particular kind. */ ! static try kind_value_check (gfc_expr *e, int n, int k) { if (e->ts.kind == k) --- 266,272 ---- /* Check that an expression has a particular kind. */ ! static gfc_try kind_value_check (gfc_expr *e, int n, int k) { if (e->ts.kind == k) *************** kind_value_check (gfc_expr *e, int n, in *** 282,288 **** /* Make sure an expression is a variable. */ ! static try variable_check (gfc_expr *e, int n) { if ((e->expr_type == EXPR_VARIABLE --- 282,288 ---- /* Make sure an expression is a variable. */ ! static gfc_try variable_check (gfc_expr *e, int n) { if ((e->expr_type == EXPR_VARIABLE *************** variable_check (gfc_expr *e, int n) *** 309,315 **** /* Check the common DIM parameter for correctness. */ ! static try dim_check (gfc_expr *dim, int n, bool optional) { if (dim == NULL) --- 309,315 ---- /* Check the common DIM parameter for correctness. */ ! static gfc_try dim_check (gfc_expr *dim, int n, bool optional) { if (dim == NULL) *************** dim_check (gfc_expr *dim, int n, bool op *** 333,354 **** allow_assumed is zero then dim must be less than the rank of the array for assumed size arrays. */ ! static try dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) { gfc_array_ref *ar; int rank; ! if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE) return SUCCESS; - ar = gfc_find_array_ref (array); rank = array->rank; ! if (ar->as->type == AS_ASSUMED_SIZE ! && !allow_assumed ! && ar->type != AR_ELEMENT ! && ar->type != AR_SECTION) ! rank--; if (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, rank) > 0) --- 333,359 ---- allow_assumed is zero then dim must be less than the rank of the array for assumed size arrays. */ ! static gfc_try dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) { gfc_array_ref *ar; int rank; ! if (dim->expr_type != EXPR_CONSTANT ! || (array->expr_type != EXPR_VARIABLE ! && array->expr_type != EXPR_ARRAY)) return SUCCESS; rank = array->rank; ! if (array->expr_type == EXPR_VARIABLE) ! { ! ar = gfc_find_array_ref (array); ! if (ar->as->type == AS_ASSUMED_SIZE ! && !allow_assumed ! && ar->type != AR_ELEMENT ! && ar->type != AR_SECTION) ! rank--; ! } if (mpz_cmp_ui (dim->value.integer, 1) < 0 || mpz_cmp_ui (dim->value.integer, rank) > 0) *************** identical_dimen_shape (gfc_expr *a, int *** 396,403 **** /* Check whether two character expressions have the same length; returns SUCCESS if they have or if the length cannot be determined. */ ! static try ! check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) { long len_a, len_b; len_a = len_b = -1; --- 401,408 ---- /* Check whether two character expressions have the same length; returns SUCCESS if they have or if the length cannot be determined. */ ! gfc_try ! gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) { long len_a, len_b; len_a = len_b = -1; *************** check_same_strlen (const gfc_expr *a, co *** 423,430 **** if (len_a == len_b) return SUCCESS; ! gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic " ! "at %L", len_a, len_b, name, &a->where); return FAILURE; } --- 428,435 ---- if (len_a == len_b) return SUCCESS; ! gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", ! len_a, len_b, name, &a->where); return FAILURE; } *************** check_same_strlen (const gfc_expr *a, co *** 434,440 **** /* Check subroutine suitable for intrinsics taking a real argument and a kind argument for the result. */ ! static try check_a_kind (gfc_expr *a, gfc_expr *kind, bt type) { if (type_check (a, 0, BT_REAL) == FAILURE) --- 439,445 ---- /* Check subroutine suitable for intrinsics taking a real argument and a kind argument for the result. */ ! static gfc_try check_a_kind (gfc_expr *a, gfc_expr *kind, bt type) { if (type_check (a, 0, BT_REAL) == FAILURE) *************** check_a_kind (gfc_expr *a, gfc_expr *kin *** 448,454 **** /* Check subroutine suitable for ceiling, floor and nint. */ ! try gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind) { return check_a_kind (a, kind, BT_INTEGER); --- 453,459 ---- /* Check subroutine suitable for ceiling, floor and nint. */ ! gfc_try gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind) { return check_a_kind (a, kind, BT_INTEGER); *************** gfc_check_a_ikind (gfc_expr *a, gfc_expr *** 457,470 **** /* Check subroutine suitable for aint, anint. */ ! try gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind) { return check_a_kind (a, kind, BT_REAL); } ! try gfc_check_abs (gfc_expr *a) { if (numeric_check (a, 0) == FAILURE) --- 462,475 ---- /* Check subroutine suitable for aint, anint. */ ! gfc_try gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind) { return check_a_kind (a, kind, BT_REAL); } ! gfc_try gfc_check_abs (gfc_expr *a) { if (numeric_check (a, 0) == FAILURE) *************** gfc_check_abs (gfc_expr *a) *** 474,480 **** } ! try gfc_check_achar (gfc_expr *a, gfc_expr *kind) { if (type_check (a, 0, BT_INTEGER) == FAILURE) --- 479,485 ---- } ! gfc_try gfc_check_achar (gfc_expr *a, gfc_expr *kind) { if (type_check (a, 0, BT_INTEGER) == FAILURE) *************** gfc_check_achar (gfc_expr *a, gfc_expr * *** 486,507 **** } ! try gfc_check_access_func (gfc_expr *name, gfc_expr *mode) { if (type_check (name, 0, BT_CHARACTER) == FAILURE || scalar_check (name, 0) == FAILURE) return FAILURE; if (type_check (mode, 1, BT_CHARACTER) == FAILURE || scalar_check (mode, 1) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) { if (logical_array_check (mask, 0) == FAILURE) --- 491,516 ---- } ! gfc_try gfc_check_access_func (gfc_expr *name, gfc_expr *mode) { if (type_check (name, 0, BT_CHARACTER) == FAILURE || scalar_check (name, 0) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (mode, 1, BT_CHARACTER) == FAILURE || scalar_check (mode, 1) == FAILURE) return FAILURE; + if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) { if (logical_array_check (mask, 0) == FAILURE) *************** gfc_check_all_any (gfc_expr *mask, gfc_e *** 514,520 **** } ! try gfc_check_allocated (gfc_expr *array) { symbol_attribute attr; --- 523,529 ---- } ! gfc_try gfc_check_allocated (gfc_expr *array) { symbol_attribute attr; *************** gfc_check_allocated (gfc_expr *array) *** 541,547 **** /* Common check function where the first argument must be real or integer and the second argument must be the same as the first. */ ! try gfc_check_a_p (gfc_expr *a, gfc_expr *p) { if (int_or_real_check (a, 0) == FAILURE) --- 550,556 ---- /* Common check function where the first argument must be real or integer and the second argument must be the same as the first. */ ! gfc_try gfc_check_a_p (gfc_expr *a, gfc_expr *p) { if (int_or_real_check (a, 0) == FAILURE) *************** gfc_check_a_p (gfc_expr *a, gfc_expr *p) *** 567,573 **** } ! try gfc_check_x_yd (gfc_expr *x, gfc_expr *y) { if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE) --- 576,582 ---- } ! gfc_try gfc_check_x_yd (gfc_expr *x, gfc_expr *y) { if (double_check (x, 0) == FAILURE || double_check (y, 1) == FAILURE) *************** gfc_check_x_yd (gfc_expr *x, gfc_expr *y *** 577,602 **** } ! try gfc_check_associated (gfc_expr *pointer, gfc_expr *target) { ! 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. */ ! if (!attr.pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", gfc_current_intrinsic_arg[0], gfc_current_intrinsic, --- 586,611 ---- } ! gfc_try gfc_check_associated (gfc_expr *pointer, gfc_expr *target) { ! symbol_attribute attr1, attr2; int i; ! gfc_try t; locus *where; where = &pointer->where; if (pointer->expr_type == EXPR_VARIABLE) ! attr1 = gfc_variable_attr (pointer, NULL); else if (pointer->expr_type == EXPR_FUNCTION) ! attr1 = pointer->symtree->n.sym->attr; else if (pointer->expr_type == EXPR_NULL) goto null_arg; else gcc_assert (0); /* Pointer must be a variable or a function. */ ! if (!attr1.pointer && !attr1.proc_pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", gfc_current_intrinsic_arg[0], gfc_current_intrinsic, *************** gfc_check_associated (gfc_expr *pointer, *** 613,621 **** 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 " --- 622,630 ---- goto null_arg; if (target->expr_type == EXPR_VARIABLE) ! attr2 = gfc_variable_attr (target, NULL); else if (target->expr_type == EXPR_FUNCTION) ! attr2 = target->symtree->n.sym->attr; else { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer " *************** gfc_check_associated (gfc_expr *pointer, *** 624,630 **** return FAILURE; } ! if (!attr.pointer && !attr.target) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER " "or a TARGET", gfc_current_intrinsic_arg[1], --- 633,639 ---- return FAILURE; } ! if (attr1.pointer && !attr2.pointer && !attr2.target) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER " "or a TARGET", gfc_current_intrinsic_arg[1], *************** null_arg: *** 660,666 **** } ! try gfc_check_atan2 (gfc_expr *y, gfc_expr *x) { if (type_check (y, 0, BT_REAL) == FAILURE) --- 669,675 ---- } ! gfc_try gfc_check_atan2 (gfc_expr *y, gfc_expr *x) { if (type_check (y, 0, BT_REAL) == FAILURE) *************** gfc_check_atan2 (gfc_expr *y, gfc_expr * *** 674,680 **** /* BESJN and BESYN functions. */ ! try gfc_check_besn (gfc_expr *n, gfc_expr *x) { if (type_check (n, 0, BT_INTEGER) == FAILURE) --- 683,689 ---- /* BESJN and BESYN functions. */ ! gfc_try gfc_check_besn (gfc_expr *n, gfc_expr *x) { if (type_check (n, 0, BT_INTEGER) == FAILURE) *************** gfc_check_besn (gfc_expr *n, gfc_expr *x *** 687,693 **** } ! try gfc_check_btest (gfc_expr *i, gfc_expr *pos) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 696,702 ---- } ! gfc_try gfc_check_btest (gfc_expr *i, gfc_expr *pos) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_btest (gfc_expr *i, gfc_expr * *** 699,705 **** } ! try gfc_check_char (gfc_expr *i, gfc_expr *kind) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 708,714 ---- } ! gfc_try gfc_check_char (gfc_expr *i, gfc_expr *kind) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_char (gfc_expr *i, gfc_expr *k *** 711,738 **** } ! try gfc_check_chdir (gfc_expr *dir) { if (type_check (dir, 0, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status) { if (type_check (dir, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (status == NULL) return SUCCESS; if (type_check (status, 1, BT_INTEGER) == FAILURE) return FAILURE; - if (scalar_check (status, 1) == FAILURE) return FAILURE; --- 720,750 ---- } ! gfc_try gfc_check_chdir (gfc_expr *dir) { if (type_check (dir, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status) { if (type_check (dir, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (dir, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; if (type_check (status, 1, BT_INTEGER) == FAILURE) return FAILURE; if (scalar_check (status, 1) == FAILURE) return FAILURE; *************** gfc_check_chdir_sub (gfc_expr *dir, gfc_ *** 740,766 **** } ! try gfc_check_chmod (gfc_expr *name, gfc_expr *mode) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (mode, 1, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (mode, 1, BT_CHARACTER) == FAILURE) return FAILURE; if (status == NULL) return SUCCESS; --- 752,786 ---- } ! gfc_try gfc_check_chmod (gfc_expr *name, gfc_expr *mode) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (mode, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (mode, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (mode, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; *************** gfc_check_chmod_sub (gfc_expr *name, gfc *** 775,781 **** } ! try gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) { if (numeric_check (x, 0) == FAILURE) --- 795,801 ---- } ! gfc_try gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) { if (numeric_check (x, 0) == FAILURE) *************** gfc_check_cmplx (gfc_expr *x, gfc_expr * *** 802,808 **** } ! try gfc_check_complex (gfc_expr *x, gfc_expr *y) { if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) --- 822,828 ---- } ! gfc_try gfc_check_complex (gfc_expr *x, gfc_expr *y) { if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) *************** gfc_check_complex (gfc_expr *x, gfc_expr *** 829,835 **** } ! try gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) { if (logical_array_check (mask, 0) == FAILURE) --- 849,855 ---- } ! gfc_try gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) { if (logical_array_check (mask, 0) == FAILURE) *************** gfc_check_count (gfc_expr *mask, gfc_exp *** 847,853 **** } ! try gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) { if (array_check (array, 0) == FAILURE) --- 867,873 ---- } ! gfc_try gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) { if (array_check (array, 0) == FAILURE) *************** gfc_check_cshift (gfc_expr *array, gfc_e *** 861,871 **** if (scalar_check (shift, 1) == FAILURE) return FAILURE; } ! else { ! /* TODO: more requirements on shift parameter. */ } if (dim_check (dim, 2, true) == FAILURE) return FAILURE; --- 881,896 ---- if (scalar_check (shift, 1) == FAILURE) return FAILURE; } ! else if (shift->rank != array->rank - 1 && shift->rank != 0) { ! gfc_error ("SHIFT argument at %L of CSHIFT must have rank %d or be a " ! "scalar", &shift->where, array->rank - 1); ! return FAILURE; } + /* TODO: Add shape conformance check between array (w/o dimension dim) + and shift. */ + if (dim_check (dim, 2, true) == FAILURE) return FAILURE; *************** gfc_check_cshift (gfc_expr *array, gfc_e *** 873,879 **** } ! try gfc_check_ctime (gfc_expr *time) { if (scalar_check (time, 0) == FAILURE) --- 898,904 ---- } ! gfc_try gfc_check_ctime (gfc_expr *time) { if (scalar_check (time, 0) == FAILURE) *************** gfc_check_ctime (gfc_expr *time) *** 886,892 **** } ! try gfc_check_datan2 (gfc_expr *y, gfc_expr *x) { if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE) return FAILURE; --- 911,917 ---- } ! gfc_try gfc_check_datan2 (gfc_expr *y, gfc_expr *x) { if (double_check (y, 0) == FAILURE || double_check (x, 1) == FAILURE) return FAILURE; *************** try gfc_check_datan2 (gfc_expr *y, gfc_e *** 894,900 **** return SUCCESS; } ! try gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) { if (numeric_check (x, 0) == FAILURE) --- 919,925 ---- return SUCCESS; } ! gfc_try gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) { if (numeric_check (x, 0) == FAILURE) *************** gfc_check_dcmplx (gfc_expr *x, gfc_expr *** 918,924 **** } ! try gfc_check_dble (gfc_expr *x) { if (numeric_check (x, 0) == FAILURE) --- 943,949 ---- } ! gfc_try gfc_check_dble (gfc_expr *x) { if (numeric_check (x, 0) == FAILURE) *************** gfc_check_dble (gfc_expr *x) *** 928,934 **** } ! try gfc_check_digits (gfc_expr *x) { if (int_or_real_check (x, 0) == FAILURE) --- 953,959 ---- } ! gfc_try gfc_check_digits (gfc_expr *x) { if (int_or_real_check (x, 0) == FAILURE) *************** gfc_check_digits (gfc_expr *x) *** 938,944 **** } ! try gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) { switch (vector_a->ts.type) --- 963,969 ---- } ! gfc_try gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) { switch (vector_a->ts.type) *************** gfc_check_dot_product (gfc_expr *vector_ *** 980,986 **** } ! try gfc_check_dprod (gfc_expr *x, gfc_expr *y) { if (type_check (x, 0, BT_REAL) == FAILURE --- 1005,1011 ---- } ! gfc_try gfc_check_dprod (gfc_expr *x, gfc_expr *y) { if (type_check (x, 0, BT_REAL) == FAILURE *************** gfc_check_dprod (gfc_expr *x, gfc_expr * *** 1007,1013 **** } ! try gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_expr *dim) { --- 1032,1038 ---- } ! gfc_try gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_expr *dim) { *************** gfc_check_eoshift (gfc_expr *array, gfc_ *** 1022,1038 **** if (scalar_check (shift, 2) == FAILURE) return FAILURE; } ! else { ! /* TODO: more weird restrictions on shift. */ } if (boundary != NULL) { if (same_type_check (array, 0, boundary, 2) == FAILURE) return FAILURE; ! /* TODO: more restrictions on boundary. */ } if (dim_check (dim, 4, true) == FAILURE) --- 1047,1091 ---- if (scalar_check (shift, 2) == FAILURE) return FAILURE; } ! else if (shift->rank != array->rank - 1 && shift->rank != 0) { ! gfc_error ("SHIFT argument at %L of EOSHIFT must have rank %d or be a " ! "scalar", &shift->where, array->rank - 1); ! return FAILURE; } + /* TODO: Add shape conformance check between array (w/o dimension dim) + and shift. */ + if (boundary != NULL) { if (same_type_check (array, 0, boundary, 2) == FAILURE) return FAILURE; ! if (array->rank == 1) ! { ! if (scalar_check (boundary, 2) == FAILURE) ! return FAILURE; ! } ! else if (boundary->rank != array->rank - 1 && boundary->rank != 0) ! { ! gfc_error ("BOUNDARY argument at %L of EOSHIFT must have rank %d or be " ! "a scalar", &boundary->where, array->rank - 1); ! return FAILURE; ! } ! ! if (shift->rank == boundary->rank) ! { ! int i; ! for (i = 0; i < shift->rank; i++) ! if (! identical_dimen_shape (shift, i, boundary, i)) ! { ! gfc_error ("Different shape in dimension %d for SHIFT and " ! "BOUNDARY arguments of EOSHIFT at %L", shift->rank, ! &boundary->where); ! return FAILURE; ! } ! } } if (dim_check (dim, 4, true) == FAILURE) *************** gfc_check_eoshift (gfc_expr *array, gfc_ *** 1044,1050 **** /* A single complex argument. */ ! try gfc_check_fn_c (gfc_expr *a) { if (type_check (a, 0, BT_COMPLEX) == FAILURE) --- 1097,1103 ---- /* A single complex argument. */ ! gfc_try gfc_check_fn_c (gfc_expr *a) { if (type_check (a, 0, BT_COMPLEX) == FAILURE) *************** gfc_check_fn_c (gfc_expr *a) *** 1056,1062 **** /* A single real argument. */ ! try gfc_check_fn_r (gfc_expr *a) { if (type_check (a, 0, BT_REAL) == FAILURE) --- 1109,1115 ---- /* A single real argument. */ ! gfc_try gfc_check_fn_r (gfc_expr *a) { if (type_check (a, 0, BT_REAL) == FAILURE) *************** gfc_check_fn_r (gfc_expr *a) *** 1067,1073 **** /* A single double argument. */ ! try gfc_check_fn_d (gfc_expr *a) { if (double_check (a, 0) == FAILURE) --- 1120,1126 ---- /* A single double argument. */ ! gfc_try gfc_check_fn_d (gfc_expr *a) { if (double_check (a, 0) == FAILURE) *************** gfc_check_fn_d (gfc_expr *a) *** 1078,1084 **** /* A single real or complex argument. */ ! try gfc_check_fn_rc (gfc_expr *a) { if (real_or_complex_check (a, 0) == FAILURE) --- 1131,1137 ---- /* A single real or complex argument. */ ! gfc_try gfc_check_fn_rc (gfc_expr *a) { if (real_or_complex_check (a, 0) == FAILURE) *************** gfc_check_fn_rc (gfc_expr *a) *** 1088,1094 **** } ! try gfc_check_fnum (gfc_expr *unit) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) --- 1141,1147 ---- } ! gfc_try gfc_check_fnum (gfc_expr *unit) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) *************** gfc_check_fnum (gfc_expr *unit) *** 1101,1107 **** } ! try gfc_check_huge (gfc_expr *x) { if (int_or_real_check (x, 0) == FAILURE) --- 1154,1160 ---- } ! gfc_try gfc_check_huge (gfc_expr *x) { if (int_or_real_check (x, 0) == FAILURE) *************** gfc_check_huge (gfc_expr *x) *** 1111,1119 **** } /* Check that the single argument is an integer. */ ! try gfc_check_i (gfc_expr *i) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 1164,1184 ---- } + gfc_try + gfc_check_hypot (gfc_expr *x, gfc_expr *y) + { + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + if (same_type_check (x, 0, y, 1) == FAILURE) + return FAILURE; + + return SUCCESS; + } + + /* Check that the single argument is an integer. */ ! gfc_try gfc_check_i (gfc_expr *i) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_i (gfc_expr *i) *** 1123,1129 **** } ! try gfc_check_iand (gfc_expr *i, gfc_expr *j) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 1188,1194 ---- } ! gfc_try gfc_check_iand (gfc_expr *i, gfc_expr *j) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_iand (gfc_expr *i, gfc_expr *j *** 1143,1149 **** } ! try gfc_check_ibclr (gfc_expr *i, gfc_expr *pos) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 1208,1214 ---- } ! gfc_try gfc_check_ibclr (gfc_expr *i, gfc_expr *pos) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_ibclr (gfc_expr *i, gfc_expr * *** 1156,1162 **** } ! try gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 1221,1227 ---- } ! gfc_try gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_ibits (gfc_expr *i, gfc_expr * *** 1172,1178 **** } ! try gfc_check_ibset (gfc_expr *i, gfc_expr *pos) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 1237,1243 ---- } ! gfc_try gfc_check_ibset (gfc_expr *i, gfc_expr *pos) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_ibset (gfc_expr *i, gfc_expr * *** 1185,1191 **** } ! try gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) { int i; --- 1250,1256 ---- } ! gfc_try gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) { int i; *************** gfc_check_ichar_iachar (gfc_expr *c, gfc *** 1256,1262 **** } ! try gfc_check_idnint (gfc_expr *a) { if (double_check (a, 0) == FAILURE) --- 1321,1327 ---- } ! gfc_try gfc_check_idnint (gfc_expr *a) { if (double_check (a, 0) == FAILURE) *************** gfc_check_idnint (gfc_expr *a) *** 1266,1272 **** } ! try gfc_check_ieor (gfc_expr *i, gfc_expr *j) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 1331,1337 ---- } ! gfc_try gfc_check_ieor (gfc_expr *i, gfc_expr *j) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_ieor (gfc_expr *i, gfc_expr *j *** 1286,1292 **** } ! try gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, gfc_expr *kind) { --- 1351,1357 ---- } ! gfc_try gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, gfc_expr *kind) { *************** gfc_check_index (gfc_expr *string, gfc_e *** 1317,1323 **** } ! try gfc_check_int (gfc_expr *x, gfc_expr *kind) { if (numeric_check (x, 0) == FAILURE) --- 1382,1388 ---- } ! gfc_try gfc_check_int (gfc_expr *x, gfc_expr *kind) { if (numeric_check (x, 0) == FAILURE) *************** gfc_check_int (gfc_expr *x, gfc_expr *ki *** 1330,1336 **** } ! try gfc_check_intconv (gfc_expr *x) { if (numeric_check (x, 0) == FAILURE) --- 1395,1401 ---- } ! gfc_try gfc_check_intconv (gfc_expr *x) { if (numeric_check (x, 0) == FAILURE) *************** gfc_check_intconv (gfc_expr *x) *** 1340,1346 **** } ! try gfc_check_ior (gfc_expr *i, gfc_expr *j) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 1405,1411 ---- } ! gfc_try gfc_check_ior (gfc_expr *i, gfc_expr *j) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_ior (gfc_expr *i, gfc_expr *j) *** 1360,1366 **** } ! try gfc_check_ishft (gfc_expr *i, gfc_expr *shift) { if (type_check (i, 0, BT_INTEGER) == FAILURE --- 1425,1431 ---- } ! gfc_try gfc_check_ishft (gfc_expr *i, gfc_expr *shift) { if (type_check (i, 0, BT_INTEGER) == FAILURE *************** gfc_check_ishft (gfc_expr *i, gfc_expr * *** 1371,1377 **** } ! try gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) { if (type_check (i, 0, BT_INTEGER) == FAILURE --- 1436,1442 ---- } ! gfc_try gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) { if (type_check (i, 0, BT_INTEGER) == FAILURE *************** gfc_check_ishftc (gfc_expr *i, gfc_expr *** 1385,1391 **** } ! try gfc_check_kill (gfc_expr *pid, gfc_expr *sig) { if (type_check (pid, 0, BT_INTEGER) == FAILURE) --- 1450,1456 ---- } ! gfc_try gfc_check_kill (gfc_expr *pid, gfc_expr *sig) { if (type_check (pid, 0, BT_INTEGER) == FAILURE) *************** gfc_check_kill (gfc_expr *pid, gfc_expr *** 1398,1404 **** } ! try gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) { if (type_check (pid, 0, BT_INTEGER) == FAILURE) --- 1463,1469 ---- } ! gfc_try gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) { if (type_check (pid, 0, BT_INTEGER) == FAILURE) *************** gfc_check_kill_sub (gfc_expr *pid, gfc_e *** 1426,1432 **** } ! try gfc_check_kind (gfc_expr *x) { if (x->ts.type == BT_DERIVED) --- 1491,1497 ---- } ! gfc_try gfc_check_kind (gfc_expr *x) { if (x->ts.type == BT_DERIVED) *************** gfc_check_kind (gfc_expr *x) *** 1441,1447 **** } ! try gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { if (array_check (array, 0) == FAILURE) --- 1506,1512 ---- } ! gfc_try gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { if (array_check (array, 0) == FAILURE) *************** gfc_check_lbound (gfc_expr *array, gfc_e *** 1467,1473 **** } ! try gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) { if (type_check (s, 0, BT_CHARACTER) == FAILURE) --- 1532,1538 ---- } ! gfc_try gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) { if (type_check (s, 0, BT_CHARACTER) == FAILURE) *************** gfc_check_len_lentrim (gfc_expr *s, gfc_ *** 1484,1510 **** } ! try gfc_check_link (gfc_expr *path1, gfc_expr *path2) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; if (status == NULL) return SUCCESS; --- 1549,1600 ---- } ! gfc_try ! gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b) ! { ! if (type_check (a, 0, BT_CHARACTER) == FAILURE) ! return FAILURE; ! if (kind_value_check (a, 0, gfc_default_character_kind) == FAILURE) ! return FAILURE; ! ! if (type_check (b, 1, BT_CHARACTER) == FAILURE) ! return FAILURE; ! if (kind_value_check (b, 1, gfc_default_character_kind) == FAILURE) ! return FAILURE; ! ! return SUCCESS; ! } ! ! ! gfc_try gfc_check_link (gfc_expr *path1, gfc_expr *path2) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; *************** gfc_check_link_sub (gfc_expr *path1, gfc *** 1519,1552 **** } ! try gfc_check_loc (gfc_expr *expr) { return variable_check (expr, 0); } ! try gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; if (status == NULL) return SUCCESS; --- 1609,1650 ---- } ! gfc_try gfc_check_loc (gfc_expr *expr) { return variable_check (expr, 0); } ! gfc_try gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; *************** gfc_check_symlnk_sub (gfc_expr *path1, g *** 1561,1567 **** } ! try gfc_check_logical (gfc_expr *a, gfc_expr *kind) { if (type_check (a, 0, BT_LOGICAL) == FAILURE) --- 1659,1665 ---- } ! gfc_try gfc_check_logical (gfc_expr *a, gfc_expr *kind) { if (type_check (a, 0, BT_LOGICAL) == FAILURE) *************** gfc_check_logical (gfc_expr *a, gfc_expr *** 1575,1581 **** /* Min/max family. */ ! static try min_max_args (gfc_actual_arglist *arg) { if (arg == NULL || arg->next == NULL) --- 1673,1679 ---- /* Min/max family. */ ! static gfc_try min_max_args (gfc_actual_arglist *arg) { if (arg == NULL || arg->next == NULL) *************** min_max_args (gfc_actual_arglist *arg) *** 1589,1595 **** } ! static try check_rest (bt type, int kind, gfc_actual_arglist *arglist) { gfc_actual_arglist *arg, *tmp; --- 1687,1693 ---- } ! static gfc_try check_rest (bt type, int kind, gfc_actual_arglist *arglist) { gfc_actual_arglist *arg, *tmp; *************** check_rest (bt type, int kind, gfc_actua *** 1634,1640 **** } ! try gfc_check_min_max (gfc_actual_arglist *arg) { gfc_expr *x; --- 1732,1738 ---- } ! gfc_try gfc_check_min_max (gfc_actual_arglist *arg) { gfc_expr *x; *************** gfc_check_min_max (gfc_actual_arglist *a *** 1662,1682 **** } ! try gfc_check_min_max_integer (gfc_actual_arglist *arg) { return check_rest (BT_INTEGER, gfc_default_integer_kind, arg); } ! try gfc_check_min_max_real (gfc_actual_arglist *arg) { return check_rest (BT_REAL, gfc_default_real_kind, arg); } ! try gfc_check_min_max_double (gfc_actual_arglist *arg) { return check_rest (BT_REAL, gfc_default_double_kind, arg); --- 1760,1780 ---- } ! gfc_try gfc_check_min_max_integer (gfc_actual_arglist *arg) { return check_rest (BT_INTEGER, gfc_default_integer_kind, arg); } ! gfc_try gfc_check_min_max_real (gfc_actual_arglist *arg) { return check_rest (BT_REAL, gfc_default_real_kind, arg); } ! gfc_try gfc_check_min_max_double (gfc_actual_arglist *arg) { return check_rest (BT_REAL, gfc_default_double_kind, arg); *************** gfc_check_min_max_double (gfc_actual_arg *** 1685,1691 **** /* End of min/max family. */ ! try gfc_check_malloc (gfc_expr *size) { if (type_check (size, 0, BT_INTEGER) == FAILURE) --- 1783,1789 ---- /* End of min/max family. */ ! gfc_try gfc_check_malloc (gfc_expr *size) { if (type_check (size, 0, BT_INTEGER) == FAILURE) *************** gfc_check_malloc (gfc_expr *size) *** 1698,1707 **** } ! try gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { ! if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[0], --- 1796,1805 ---- } ! gfc_try gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) { ! if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[0], *************** gfc_check_matmul (gfc_expr *matrix_a, gf *** 1709,1715 **** return FAILURE; } ! if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[1], --- 1807,1813 ---- return FAILURE; } ! if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric " "or LOGICAL", gfc_current_intrinsic_arg[1], *************** gfc_check_matmul (gfc_expr *matrix_a, gf *** 1717,1722 **** --- 1815,1829 ---- return FAILURE; } + if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts)) + || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)) + { + gfc_error ("Argument types of '%s' intrinsic at %L must match (%s/%s)", + gfc_current_intrinsic, &matrix_a->where, + gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts)); + return FAILURE; + } + switch (matrix_a->rank) { case 1: *************** gfc_check_matmul (gfc_expr *matrix_a, gf *** 1777,1783 **** I.e. in the case of minloc(array,mask), mask will be in the second position of the argument list and we'll have to fix that up. */ ! try gfc_check_minloc_maxloc (gfc_actual_arglist *ap) { gfc_expr *a, *m, *d; --- 1884,1890 ---- I.e. in the case of minloc(array,mask), mask will be in the second position of the argument list and we'll have to fix that up. */ ! gfc_try gfc_check_minloc_maxloc (gfc_actual_arglist *ap) { gfc_expr *a, *m, *d; *************** gfc_check_minloc_maxloc (gfc_actual_argl *** 1836,1842 **** I.e. in the case of minval(array,mask), mask will be in the second position of the argument list and we'll have to fix that up. */ ! static try check_reduction (gfc_actual_arglist *ap) { gfc_expr *a, *m, *d; --- 1943,1949 ---- I.e. in the case of minval(array,mask), mask will be in the second position of the argument list and we'll have to fix that up. */ ! static gfc_try check_reduction (gfc_actual_arglist *ap) { gfc_expr *a, *m, *d; *************** check_reduction (gfc_actual_arglist *ap) *** 1877,1883 **** } ! try gfc_check_minval_maxval (gfc_actual_arglist *ap) { if (int_or_real_check (ap->expr, 0) == FAILURE --- 1984,1990 ---- } ! gfc_try gfc_check_minval_maxval (gfc_actual_arglist *ap) { if (int_or_real_check (ap->expr, 0) == FAILURE *************** gfc_check_minval_maxval (gfc_actual_argl *** 1888,1894 **** } ! try gfc_check_product_sum (gfc_actual_arglist *ap) { if (numeric_check (ap->expr, 0) == FAILURE --- 1995,2001 ---- } ! gfc_try gfc_check_product_sum (gfc_actual_arglist *ap) { if (numeric_check (ap->expr, 0) == FAILURE *************** gfc_check_product_sum (gfc_actual_arglis *** 1899,1905 **** } ! try gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) { if (same_type_check (tsource, 0, fsource, 1) == FAILURE) --- 2006,2012 ---- } ! gfc_try gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) { if (same_type_check (tsource, 0, fsource, 1) == FAILURE) *************** gfc_check_merge (gfc_expr *tsource, gfc_ *** 1909,1921 **** return FAILURE; if (tsource->ts.type == BT_CHARACTER) ! return check_same_strlen (tsource, fsource, "MERGE"); return SUCCESS; } ! try gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) { symbol_attribute attr; --- 2016,2028 ---- return FAILURE; if (tsource->ts.type == BT_CHARACTER) ! return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic"); return SUCCESS; } ! gfc_try gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) { symbol_attribute attr; *************** gfc_check_move_alloc (gfc_expr *from, gf *** 1975,1981 **** } ! try gfc_check_nearest (gfc_expr *x, gfc_expr *s) { if (type_check (x, 0, BT_REAL) == FAILURE) --- 2082,2088 ---- } ! gfc_try gfc_check_nearest (gfc_expr *x, gfc_expr *s) { if (type_check (x, 0, BT_REAL) == FAILURE) *************** gfc_check_nearest (gfc_expr *x, gfc_expr *** 1988,1994 **** } ! try gfc_check_new_line (gfc_expr *a) { if (type_check (a, 0, BT_CHARACTER) == FAILURE) --- 2095,2101 ---- } ! gfc_try gfc_check_new_line (gfc_expr *a) { if (type_check (a, 0, BT_CHARACTER) == FAILURE) *************** gfc_check_new_line (gfc_expr *a) *** 1998,2004 **** } ! try gfc_check_null (gfc_expr *mold) { symbol_attribute attr; --- 2105,2111 ---- } ! gfc_try gfc_check_null (gfc_expr *mold) { symbol_attribute attr; *************** gfc_check_null (gfc_expr *mold) *** 2011,2017 **** attr = gfc_variable_attr (mold, NULL); ! if (!attr.pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", gfc_current_intrinsic_arg[0], --- 2118,2124 ---- attr = gfc_variable_attr (mold, NULL); ! if (!attr.pointer && !attr.proc_pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", gfc_current_intrinsic_arg[0], *************** gfc_check_null (gfc_expr *mold) *** 2023,2029 **** } ! try gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) { char buffer[80]; --- 2130,2136 ---- } ! gfc_try gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) { char buffer[80]; *************** gfc_check_pack (gfc_expr *array, gfc_exp *** 2055,2061 **** } ! try gfc_check_precision (gfc_expr *x) { if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX) --- 2162,2168 ---- } ! gfc_try gfc_check_precision (gfc_expr *x) { if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX) *************** gfc_check_precision (gfc_expr *x) *** 2070,2076 **** } ! try gfc_check_present (gfc_expr *a) { gfc_symbol *sym; --- 2177,2183 ---- } ! gfc_try gfc_check_present (gfc_expr *a) { gfc_symbol *sym; *************** gfc_check_present (gfc_expr *a) *** 2115,2121 **** } ! try gfc_check_radix (gfc_expr *x) { if (int_or_real_check (x, 0) == FAILURE) --- 2222,2228 ---- } ! gfc_try gfc_check_radix (gfc_expr *x) { if (int_or_real_check (x, 0) == FAILURE) *************** gfc_check_radix (gfc_expr *x) *** 2125,2131 **** } ! try gfc_check_range (gfc_expr *x) { if (numeric_check (x, 0) == FAILURE) --- 2232,2238 ---- } ! gfc_try gfc_check_range (gfc_expr *x) { if (numeric_check (x, 0) == FAILURE) *************** gfc_check_range (gfc_expr *x) *** 2136,2142 **** /* real, float, sngl. */ ! try gfc_check_real (gfc_expr *a, gfc_expr *kind) { if (numeric_check (a, 0) == FAILURE) --- 2243,2249 ---- /* real, float, sngl. */ ! gfc_try gfc_check_real (gfc_expr *a, gfc_expr *kind) { if (numeric_check (a, 0) == FAILURE) *************** gfc_check_real (gfc_expr *a, gfc_expr *k *** 2149,2175 **** } ! try gfc_check_rename (gfc_expr *path1, gfc_expr *path2) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; if (status == NULL) return SUCCESS; --- 2256,2290 ---- } ! gfc_try gfc_check_rename (gfc_expr *path1, gfc_expr *path2) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) { if (type_check (path1, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path1, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (path2, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (path2, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; *************** gfc_check_rename_sub (gfc_expr *path1, g *** 2184,2190 **** } ! try gfc_check_repeat (gfc_expr *x, gfc_expr *y) { if (type_check (x, 0, BT_CHARACTER) == FAILURE) --- 2299,2305 ---- } ! gfc_try gfc_check_repeat (gfc_expr *x, gfc_expr *y) { if (type_check (x, 0, BT_CHARACTER) == FAILURE) *************** gfc_check_repeat (gfc_expr *x, gfc_expr *** 2203,2209 **** } ! try gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_expr *pad, gfc_expr *order) { --- 2318,2324 ---- } ! gfc_try gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_expr *pad, gfc_expr *order) { *************** gfc_check_reshape (gfc_expr *source, gfc *** 2282,2288 **** } ! try gfc_check_scale (gfc_expr *x, gfc_expr *i) { if (type_check (x, 0, BT_REAL) == FAILURE) --- 2397,2403 ---- } ! gfc_try gfc_check_scale (gfc_expr *x, gfc_expr *i) { if (type_check (x, 0, BT_REAL) == FAILURE) *************** gfc_check_scale (gfc_expr *x, gfc_expr * *** 2295,2301 **** } ! try gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) { if (type_check (x, 0, BT_CHARACTER) == FAILURE) --- 2410,2416 ---- } ! gfc_try gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) { if (type_check (x, 0, BT_CHARACTER) == FAILURE) *************** gfc_check_scan (gfc_expr *x, gfc_expr *y *** 2321,2327 **** } ! try gfc_check_secnds (gfc_expr *r) { if (type_check (r, 0, BT_REAL) == FAILURE) --- 2436,2442 ---- } ! gfc_try gfc_check_secnds (gfc_expr *r) { if (type_check (r, 0, BT_REAL) == FAILURE) *************** gfc_check_secnds (gfc_expr *r) *** 2337,2343 **** } ! try gfc_check_selected_int_kind (gfc_expr *r) { if (type_check (r, 0, BT_INTEGER) == FAILURE) --- 2452,2474 ---- } ! gfc_try ! gfc_check_selected_char_kind (gfc_expr *name) ! { ! if (type_check (name, 0, BT_CHARACTER) == FAILURE) ! return FAILURE; ! ! if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) ! return FAILURE; ! ! if (scalar_check (name, 0) == FAILURE) ! return FAILURE; ! ! return SUCCESS; ! } ! ! ! gfc_try gfc_check_selected_int_kind (gfc_expr *r) { if (type_check (r, 0, BT_INTEGER) == FAILURE) *************** gfc_check_selected_int_kind (gfc_expr *r *** 2350,2356 **** } ! try gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r) { if (p == NULL && r == NULL) --- 2481,2487 ---- } ! gfc_try gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r) { if (p == NULL && r == NULL) *************** gfc_check_selected_real_kind (gfc_expr * *** 2371,2377 **** } ! try gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) { if (type_check (x, 0, BT_REAL) == FAILURE) --- 2502,2508 ---- } ! gfc_try gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) { if (type_check (x, 0, BT_REAL) == FAILURE) *************** gfc_check_set_exponent (gfc_expr *x, gfc *** 2384,2390 **** } ! try gfc_check_shape (gfc_expr *source) { gfc_array_ref *ar; --- 2515,2521 ---- } ! gfc_try gfc_check_shape (gfc_expr *source) { gfc_array_ref *ar; *************** gfc_check_shape (gfc_expr *source) *** 2405,2411 **** } ! try gfc_check_sign (gfc_expr *a, gfc_expr *b) { if (int_or_real_check (a, 0) == FAILURE) --- 2536,2542 ---- } ! gfc_try gfc_check_sign (gfc_expr *a, gfc_expr *b) { if (int_or_real_check (a, 0) == FAILURE) *************** gfc_check_sign (gfc_expr *a, gfc_expr *b *** 2418,2424 **** } ! try gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { if (array_check (array, 0) == FAILURE) --- 2549,2555 ---- } ! gfc_try gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { if (array_check (array, 0) == FAILURE) *************** gfc_check_size (gfc_expr *array, gfc_exp *** 2445,2458 **** } ! try ! gfc_check_sizeof (gfc_expr *arg __attribute__((unused))) { return SUCCESS; } ! try gfc_check_sleep_sub (gfc_expr *seconds) { if (type_check (seconds, 0, BT_INTEGER) == FAILURE) --- 2576,2589 ---- } ! gfc_try ! gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED) { return SUCCESS; } ! gfc_try gfc_check_sleep_sub (gfc_expr *seconds) { if (type_check (seconds, 0, BT_INTEGER) == FAILURE) *************** gfc_check_sleep_sub (gfc_expr *seconds) *** 2465,2471 **** } ! try gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) { if (source->rank >= GFC_MAX_DIMENSIONS) --- 2596,2602 ---- } ! gfc_try gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) { if (source->rank >= GFC_MAX_DIMENSIONS) *************** gfc_check_spread (gfc_expr *source, gfc_ *** 2496,2502 **** /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and functions). */ ! try gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) --- 2627,2633 ---- /* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and functions). */ ! gfc_try gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) *************** gfc_check_fgetputc_sub (gfc_expr *unit, *** 2507,2512 **** --- 2638,2645 ---- if (type_check (c, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (c, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; *************** gfc_check_fgetputc_sub (gfc_expr *unit, *** 2520,2537 **** } ! try gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c) { return gfc_check_fgetputc_sub (unit, c, NULL); } ! try gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) { if (type_check (c, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (status == NULL) return SUCCESS; --- 2653,2672 ---- } ! gfc_try gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c) { return gfc_check_fgetputc_sub (unit, c, NULL); } ! gfc_try gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) { if (type_check (c, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (c, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; *************** gfc_check_fgetput_sub (gfc_expr *c, gfc_ *** 2545,2558 **** } ! try gfc_check_fgetput (gfc_expr *c) { return gfc_check_fgetput_sub (c, NULL); } ! try gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) --- 2680,2693 ---- } ! gfc_try gfc_check_fgetput (gfc_expr *c) { return gfc_check_fgetput_sub (c, NULL); } ! gfc_try gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) *************** gfc_check_fseek_sub (gfc_expr *unit, gfc *** 2590,2596 **** ! try gfc_check_fstat (gfc_expr *unit, gfc_expr *array) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) --- 2725,2731 ---- ! gfc_try gfc_check_fstat (gfc_expr *unit, gfc_expr *array) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) *************** gfc_check_fstat (gfc_expr *unit, gfc_exp *** 2610,2616 **** } ! try gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) --- 2745,2751 ---- } ! gfc_try gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) *************** gfc_check_fstat_sub (gfc_expr *unit, gfc *** 2640,2646 **** } ! try gfc_check_ftell (gfc_expr *unit) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) --- 2775,2781 ---- } ! gfc_try gfc_check_ftell (gfc_expr *unit) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) *************** gfc_check_ftell (gfc_expr *unit) *** 2653,2659 **** } ! try gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) --- 2788,2794 ---- } ! gfc_try gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) { if (type_check (unit, 0, BT_INTEGER) == FAILURE) *************** gfc_check_ftell_sub (gfc_expr *unit, gfc *** 2672,2682 **** } ! try gfc_check_stat (gfc_expr *name, gfc_expr *array) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (array, 1, BT_INTEGER) == FAILURE || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) --- 2807,2819 ---- } ! gfc_try gfc_check_stat (gfc_expr *name, gfc_expr *array) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (array, 1, BT_INTEGER) == FAILURE || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) *************** gfc_check_stat (gfc_expr *name, gfc_expr *** 2689,2699 **** } ! try gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (type_check (array, 1, BT_INTEGER) == FAILURE || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) --- 2826,2838 ---- } ! gfc_try gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (type_check (array, 1, BT_INTEGER) == FAILURE || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE) *************** gfc_check_stat_sub (gfc_expr *name, gfc_ *** 2716,2722 **** } ! try gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED, gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size) { --- 2855,2861 ---- } ! gfc_try gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED, gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size) { *************** gfc_check_transfer (gfc_expr *source ATT *** 2743,2749 **** } ! try gfc_check_transpose (gfc_expr *matrix) { if (rank_check (matrix, 0, 2) == FAILURE) --- 2882,2888 ---- } ! gfc_try gfc_check_transpose (gfc_expr *matrix) { if (rank_check (matrix, 0, 2) == FAILURE) *************** gfc_check_transpose (gfc_expr *matrix) *** 2753,2759 **** } ! try gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { if (array_check (array, 0) == FAILURE) --- 2892,2898 ---- } ! gfc_try gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { if (array_check (array, 0) == FAILURE) *************** gfc_check_ubound (gfc_expr *array, gfc_e *** 2779,2785 **** } ! try gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { if (rank_check (vector, 0, 1) == FAILURE) --- 2918,2924 ---- } ! gfc_try gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { if (rank_check (vector, 0, 1) == FAILURE) *************** gfc_check_unpack (gfc_expr *vector, gfc_ *** 2794,2804 **** if (same_type_check (vector, 0, field, 2) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) { if (type_check (x, 0, BT_CHARACTER) == FAILURE) --- 2933,2962 ---- if (same_type_check (vector, 0, field, 2) == FAILURE) return FAILURE; + if (mask->rank != field->rank && field->rank != 0) + { + gfc_error ("FIELD argument at %L of UNPACK must have the same rank as " + "MASK or be a scalar", &field->where); + return FAILURE; + } + + if (mask->rank == field->rank) + { + int i; + for (i = 0; i < field->rank; i++) + if (! identical_dimen_shape (mask, i, field, i)) + { + gfc_error ("Different shape in dimension %d for MASK and FIELD " + "arguments of UNPACK at %L", mask->rank, &field->where); + return FAILURE; + } + } + return SUCCESS; } ! gfc_try gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) { if (type_check (x, 0, BT_CHARACTER) == FAILURE) *************** gfc_check_verify (gfc_expr *x, gfc_expr *** 2821,2827 **** } ! try gfc_check_trim (gfc_expr *x) { if (type_check (x, 0, BT_CHARACTER) == FAILURE) --- 2979,2985 ---- } ! gfc_try gfc_check_trim (gfc_expr *x) { if (type_check (x, 0, BT_CHARACTER) == FAILURE) *************** gfc_check_trim (gfc_expr *x) *** 2834,2840 **** } ! try gfc_check_ttynam (gfc_expr *unit) { if (scalar_check (unit, 0) == FAILURE) --- 2992,2998 ---- } ! gfc_try gfc_check_ttynam (gfc_expr *unit) { if (scalar_check (unit, 0) == FAILURE) *************** gfc_check_ttynam (gfc_expr *unit) *** 2850,2856 **** /* Common check function for the half a dozen intrinsics that have a single real argument. */ ! try gfc_check_x (gfc_expr *x) { if (type_check (x, 0, BT_REAL) == FAILURE) --- 3008,3014 ---- /* Common check function for the half a dozen intrinsics that have a single real argument. */ ! gfc_try gfc_check_x (gfc_expr *x) { if (type_check (x, 0, BT_REAL) == FAILURE) *************** gfc_check_x (gfc_expr *x) *** 2862,2868 **** /************* Check functions for intrinsic subroutines *************/ ! try gfc_check_cpu_time (gfc_expr *time) { if (scalar_check (time, 0) == FAILURE) --- 3020,3026 ---- /************* Check functions for intrinsic subroutines *************/ ! gfc_try gfc_check_cpu_time (gfc_expr *time) { if (scalar_check (time, 0) == FAILURE) *************** gfc_check_cpu_time (gfc_expr *time) *** 2878,2884 **** } ! try gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, gfc_expr *zone, gfc_expr *values) { --- 3036,3042 ---- } ! gfc_try gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, gfc_expr *zone, gfc_expr *values) { *************** gfc_check_date_and_time (gfc_expr *date, *** 2886,2891 **** --- 3044,3051 ---- { if (type_check (date, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (scalar_check (date, 0) == FAILURE) return FAILURE; if (variable_check (date, 0) == FAILURE) *************** gfc_check_date_and_time (gfc_expr *date, *** 2896,2901 **** --- 3056,3063 ---- { if (type_check (time, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (time, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; if (scalar_check (time, 1) == FAILURE) return FAILURE; if (variable_check (time, 1) == FAILURE) *************** gfc_check_date_and_time (gfc_expr *date, *** 2906,2911 **** --- 3068,3075 ---- { if (type_check (zone, 2, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (zone, 2, gfc_default_character_kind) == FAILURE) + return FAILURE; if (scalar_check (zone, 2) == FAILURE) return FAILURE; if (variable_check (zone, 2) == FAILURE) *************** gfc_check_date_and_time (gfc_expr *date, *** 2928,2934 **** } ! try gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, gfc_expr *to, gfc_expr *topos) { --- 3092,3098 ---- } ! gfc_try gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, gfc_expr *to, gfc_expr *topos) { *************** gfc_check_mvbits (gfc_expr *from, gfc_ex *** 2954,2960 **** } ! try gfc_check_random_number (gfc_expr *harvest) { if (type_check (harvest, 0, BT_REAL) == FAILURE) --- 3118,3124 ---- } ! gfc_try gfc_check_random_number (gfc_expr *harvest) { if (type_check (harvest, 0, BT_REAL) == FAILURE) *************** gfc_check_random_number (gfc_expr *harve *** 2967,2977 **** } ! try gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) { ! unsigned int nargs = 0; locus *where = NULL; if (size != NULL) { --- 3131,3149 ---- } ! gfc_try gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) { ! unsigned int nargs = 0, kiss_size; locus *where = NULL; + mpz_t put_size, get_size; + bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */ + + have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1; + + /* Keep the number of bytes in sync with kiss_size in + libgfortran/intrinsics/random.c. */ + kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind; if (size != NULL) { *************** gfc_check_random_seed (gfc_expr *size, g *** 3012,3017 **** --- 3184,3196 ---- if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE) return FAILURE; + + if (gfc_array_size (put, &put_size) == SUCCESS + && mpz_get_ui (put_size) < kiss_size) + gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " + "too small (%i/%i)", + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where, + (int) mpz_get_ui (put_size), kiss_size); } if (get != NULL) *************** gfc_check_random_seed (gfc_expr *size, g *** 3037,3042 **** --- 3216,3228 ---- if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE) return FAILURE; + + if (gfc_array_size (get, &get_size) == SUCCESS + && mpz_get_ui (get_size) < kiss_size) + gfc_error ("Size of '%s' argument of '%s' intrinsic at %L " + "too small (%i/%i)", + gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where, + (int) mpz_get_ui (get_size), kiss_size); } /* RANDOM_SEED may not have more than one non-optional argument. */ *************** gfc_check_random_seed (gfc_expr *size, g *** 3047,3053 **** } ! try gfc_check_second_sub (gfc_expr *time) { if (scalar_check (time, 0) == FAILURE) --- 3233,3239 ---- } ! gfc_try gfc_check_second_sub (gfc_expr *time) { if (scalar_check (time, 0) == FAILURE) *************** gfc_check_second_sub (gfc_expr *time) *** 3066,3072 **** /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note, count, count_rate, and count_max are all optional arguments */ ! try gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, gfc_expr *count_max) { --- 3252,3258 ---- /* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note, count, count_rate, and count_max are all optional arguments */ ! gfc_try gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, gfc_expr *count_max) { *************** gfc_check_system_clock (gfc_expr *count, *** 3123,3129 **** } ! try gfc_check_irand (gfc_expr *x) { if (x == NULL) --- 3309,3315 ---- } ! gfc_try gfc_check_irand (gfc_expr *x) { if (x == NULL) *************** gfc_check_irand (gfc_expr *x) *** 3142,3148 **** } ! try gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) { if (scalar_check (seconds, 0) == FAILURE) --- 3328,3334 ---- } ! gfc_try gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) { if (scalar_check (seconds, 0) == FAILURE) *************** gfc_check_alarm_sub (gfc_expr *seconds, *** 3178,3184 **** } ! try gfc_check_rand (gfc_expr *x) { if (x == NULL) --- 3364,3370 ---- } ! gfc_try gfc_check_rand (gfc_expr *x) { if (x == NULL) *************** gfc_check_rand (gfc_expr *x) *** 3197,3203 **** } ! try gfc_check_srand (gfc_expr *x) { if (scalar_check (x, 0) == FAILURE) --- 3383,3389 ---- } ! gfc_try gfc_check_srand (gfc_expr *x) { if (scalar_check (x, 0) == FAILURE) *************** gfc_check_srand (gfc_expr *x) *** 3213,3235 **** } ! try gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result) { if (scalar_check (time, 0) == FAILURE) return FAILURE; - if (type_check (time, 0, BT_INTEGER) == FAILURE) return FAILURE; if (type_check (result, 1, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_dtime_etime (gfc_expr *x) { if (array_check (x, 0) == FAILURE) --- 3399,3422 ---- } ! gfc_try gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result) { if (scalar_check (time, 0) == FAILURE) return FAILURE; if (type_check (time, 0, BT_INTEGER) == FAILURE) return FAILURE; if (type_check (result, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (result, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_dtime_etime (gfc_expr *x) { if (array_check (x, 0) == FAILURE) *************** gfc_check_dtime_etime (gfc_expr *x) *** 3251,3257 **** } ! try gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) { if (array_check (values, 0) == FAILURE) --- 3438,3444 ---- } ! gfc_try gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) { if (array_check (values, 0) == FAILURE) *************** gfc_check_dtime_etime_sub (gfc_expr *val *** 3282,3312 **** } ! try gfc_check_fdate_sub (gfc_expr *date) { if (type_check (date, 0, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_gerror (gfc_expr *msg) { if (type_check (msg, 0, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) { if (type_check (cwd, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (status == NULL) return SUCCESS; --- 3469,3505 ---- } ! gfc_try gfc_check_fdate_sub (gfc_expr *date) { if (type_check (date, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (date, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_gerror (gfc_expr *msg) { if (type_check (msg, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) { if (type_check (cwd, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (cwd, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; *************** gfc_check_getcwd_sub (gfc_expr *cwd, gfc *** 3321,3327 **** } ! try gfc_check_getarg (gfc_expr *pos, gfc_expr *value) { if (type_check (pos, 0, BT_INTEGER) == FAILURE) --- 3514,3520 ---- } ! gfc_try gfc_check_getarg (gfc_expr *pos, gfc_expr *value) { if (type_check (pos, 0, BT_INTEGER) == FAILURE) *************** gfc_check_getarg (gfc_expr *pos, gfc_exp *** 3338,3359 **** if (type_check (value, 1, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_getlog (gfc_expr *msg) { if (type_check (msg, 0, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_exit (gfc_expr *status) { if (status == NULL) --- 3531,3556 ---- if (type_check (value, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (value, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_getlog (gfc_expr *msg) { if (type_check (msg, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (msg, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_exit (gfc_expr *status) { if (status == NULL) *************** gfc_check_exit (gfc_expr *status) *** 3369,3375 **** } ! try gfc_check_flush (gfc_expr *unit) { if (unit == NULL) --- 3566,3572 ---- } ! gfc_try gfc_check_flush (gfc_expr *unit) { if (unit == NULL) *************** gfc_check_flush (gfc_expr *unit) *** 3385,3391 **** } ! try gfc_check_free (gfc_expr *i) { if (type_check (i, 0, BT_INTEGER) == FAILURE) --- 3582,3588 ---- } ! gfc_try gfc_check_free (gfc_expr *i) { if (type_check (i, 0, BT_INTEGER) == FAILURE) *************** gfc_check_free (gfc_expr *i) *** 3398,3418 **** } ! try gfc_check_hostnm (gfc_expr *name) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (status == NULL) return SUCCESS; --- 3595,3619 ---- } ! gfc_try gfc_check_hostnm (gfc_expr *name) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; *************** gfc_check_hostnm_sub (gfc_expr *name, gf *** 3427,3433 **** } ! try gfc_check_itime_idate (gfc_expr *values) { if (array_check (values, 0) == FAILURE) --- 3628,3634 ---- } ! gfc_try gfc_check_itime_idate (gfc_expr *values) { if (array_check (values, 0) == FAILURE) *************** gfc_check_itime_idate (gfc_expr *values) *** 3449,3455 **** } ! try gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) { if (type_check (time, 0, BT_INTEGER) == FAILURE) --- 3650,3656 ---- } ! gfc_try gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) { if (type_check (time, 0, BT_INTEGER) == FAILURE) *************** gfc_check_ltime_gmtime (gfc_expr *time, *** 3480,3486 **** } ! try gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) { if (scalar_check (unit, 0) == FAILURE) --- 3681,3687 ---- } ! gfc_try gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) { if (scalar_check (unit, 0) == FAILURE) *************** gfc_check_ttynam_sub (gfc_expr *unit, gf *** 3491,3502 **** if (type_check (name, 1, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_isatty (gfc_expr *unit) { if (unit == NULL) --- 3692,3705 ---- if (type_check (name, 1, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 1, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_isatty (gfc_expr *unit) { if (unit == NULL) *************** gfc_check_isatty (gfc_expr *unit) *** 3512,3518 **** } ! try gfc_check_isnan (gfc_expr *x) { if (type_check (x, 0, BT_REAL) == FAILURE) --- 3715,3721 ---- } ! gfc_try gfc_check_isnan (gfc_expr *x) { if (type_check (x, 0, BT_REAL) == FAILURE) *************** gfc_check_isnan (gfc_expr *x) *** 3522,3538 **** } ! try gfc_check_perror (gfc_expr *string) { if (type_check (string, 0, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_umask (gfc_expr *mask) { if (type_check (mask, 0, BT_INTEGER) == FAILURE) --- 3725,3743 ---- } ! gfc_try gfc_check_perror (gfc_expr *string) { if (type_check (string, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (string, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_umask (gfc_expr *mask) { if (type_check (mask, 0, BT_INTEGER) == FAILURE) *************** gfc_check_umask (gfc_expr *mask) *** 3545,3551 **** } ! try gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old) { if (type_check (mask, 0, BT_INTEGER) == FAILURE) --- 3750,3756 ---- } ! gfc_try gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old) { if (type_check (mask, 0, BT_INTEGER) == FAILURE) *************** gfc_check_umask_sub (gfc_expr *mask, gfc *** 3567,3587 **** } ! try gfc_check_unlink (gfc_expr *name) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; return SUCCESS; } ! try gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (status == NULL) return SUCCESS; --- 3772,3796 ---- } ! gfc_try gfc_check_unlink (gfc_expr *name) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; return SUCCESS; } ! gfc_try gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (status == NULL) return SUCCESS; *************** gfc_check_unlink_sub (gfc_expr *name, gf *** 3596,3602 **** } ! try gfc_check_signal (gfc_expr *number, gfc_expr *handler) { if (scalar_check (number, 0) == FAILURE) --- 3805,3811 ---- } ! gfc_try gfc_check_signal (gfc_expr *number, gfc_expr *handler) { if (scalar_check (number, 0) == FAILURE) *************** gfc_check_signal (gfc_expr *number, gfc_ *** 3620,3626 **** } ! try gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) { if (scalar_check (number, 0) == FAILURE) --- 3829,3835 ---- } ! gfc_try gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) { if (scalar_check (number, 0) == FAILURE) *************** gfc_check_signal_sub (gfc_expr *number, *** 3653,3663 **** } ! try gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) { if (type_check (cmd, 0, BT_CHARACTER) == FAILURE) return FAILURE; if (scalar_check (status, 1) == FAILURE) return FAILURE; --- 3862,3874 ---- } ! gfc_try gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) { if (type_check (cmd, 0, BT_CHARACTER) == FAILURE) return FAILURE; + if (kind_value_check (cmd, 0, gfc_default_character_kind) == FAILURE) + return FAILURE; if (scalar_check (status, 1) == FAILURE) return FAILURE; *************** gfc_check_system_sub (gfc_expr *cmd, gfc *** 3673,3679 **** /* This is used for the GNU intrinsics AND, OR and XOR. */ ! try gfc_check_and (gfc_expr *i, gfc_expr *j) { if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) --- 3884,3890 ---- /* This is used for the GNU intrinsics AND, OR and XOR. */ ! gfc_try gfc_check_and (gfc_expr *i, gfc_expr *j) { if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL) diff -Nrcpad gcc-4.3.3/gcc/fortran/convert.c gcc-4.4.0/gcc/fortran/convert.c *** gcc-4.3.3/gcc/fortran/convert.c Wed Aug 1 16:29:36 2007 --- gcc-4.4.0/gcc/fortran/convert.c Sun Feb 24 16:43:23 2008 *************** *** 1,5 **** /* Language-level data type conversion for GNU C. ! Copyright (C) 1987, 1988, 1991, 1998, 2002, 2007 Free Software Foundation, Inc. This file is part of GCC. --- 1,5 ---- /* Language-level data type conversion for GNU C. ! Copyright (C) 1987, 1988, 1991, 1998, 2002, 2007, 2008 Free Software Foundation, Inc. This file is part of GCC. *************** convert (tree type, tree expr) *** 89,95 **** return error_mark_node; } if (code == VOID_TYPE) ! return build1 (CONVERT_EXPR, type, e); #if 0 /* This is incorrect. A truncation can't be stripped this way. Extensions will be stripped by the use of get_unwidened. */ --- 89,95 ---- return error_mark_node; } if (code == VOID_TYPE) ! return fold_build1 (CONVERT_EXPR, type, e); #if 0 /* This is incorrect. A truncation can't be stripped this way. Extensions will be stripped by the use of get_unwidened. */ diff -Nrcpad gcc-4.3.3/gcc/fortran/cpp.c gcc-4.4.0/gcc/fortran/cpp.c *** gcc-4.3.3/gcc/fortran/cpp.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/fortran/cpp.c Tue Dec 9 19:25:55 2008 *************** *** 0 **** --- 1,1043 ---- + /* Copyright (C) 2008 Free Software Foundation, Inc. + + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 3, or (at your option) any later + version. + + GCC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + + #include "config.h" + #include "system.h" + #include "coretypes.h" + #include "tm.h" + #include "tree.h" + #include "version.h" + #include "flags.h" + + + #include "options.h" + #include "gfortran.h" + #include "tm_p.h" /* Target prototypes. */ + #include "target.h" + #include "toplev.h" + #include "diagnostic.h" + + #include "../../libcpp/internal.h" + #include "cpp.h" + #include "incpath.h" + + #ifndef TARGET_OS_CPP_BUILTINS + # define TARGET_OS_CPP_BUILTINS() + #endif + + #ifndef TARGET_OBJFMT_CPP_BUILTINS + # define TARGET_OBJFMT_CPP_BUILTINS() + #endif + + + /* Holds switches parsed by gfc_cpp_handle_option (), but whose + handling is deferred to gfc_cpp_init (). */ + typedef struct + { + enum opt_code code; + const char *arg; + } + gfc_cpp_deferred_opt_t; + + + /* Defined and undefined macros being queued for output with -dU at + the next newline. */ + typedef struct gfc_cpp_macro_queue + { + struct gfc_cpp_macro_queue *next; /* Next macro in the list. */ + char *macro; /* The name of the macro if not + defined, the full definition if + defined. */ + } gfc_cpp_macro_queue; + static gfc_cpp_macro_queue *cpp_define_queue, *cpp_undefine_queue; + + struct + { + /* Argument of -cpp, implied by SPEC; + if NULL, preprocessing disabled. */ + const char *temporary_filename; + + const char *output_filename; /* -o */ + int preprocess_only; /* -E */ + int discard_comments; /* -C */ + int discard_comments_in_macro_exp; /* -CC */ + int print_include_names; /* -H */ + int no_line_commands; /* -P */ + char dump_macros; /* -d[DMNU] */ + int dump_includes; /* -dI */ + int working_directory; /* -fworking-directory */ + int no_predefined; /* -undef */ + int standard_include_paths; /* -nostdinc */ + int verbose; /* -v */ + + const char *multilib; /* -imultilib */ + const char *prefix; /* -iprefix */ + const char *sysroot; /* -isysroot */ + + /* Options whose handling needs to be deferred until the + appropriate cpp-objects are created: + -A predicate=answer + -D [=] + -U */ + gfc_cpp_deferred_opt_t *deferred_opt; + int deferred_opt_count; + } + gfc_cpp_option; + + /* Structures used with libcpp: */ + static cpp_options *cpp_option = NULL; + static cpp_reader *cpp_in = NULL; + + /* Defined in toplev.c. */ + extern const char *asm_file_name; + + + + + /* Encapsulates state used to convert a stream of cpp-tokens into + a text file. */ + static struct + { + FILE *outf; /* Stream to write to. */ + const cpp_token *prev; /* Previous token. */ + const cpp_token *source; /* Source token for spacing. */ + int src_line; /* Line number currently being written. */ + unsigned char printed; /* Nonzero if something output at line. */ + bool first_time; /* cb_file_change hasn't been called yet. */ + } print; + + /* General output routines. */ + static void scan_translation_unit (cpp_reader *); + static void scan_translation_unit_trad (cpp_reader *); + + /* Callback routines for the parser. Most of these are active only + in specific modes. */ + static void cb_file_change (cpp_reader *, const struct line_map *); + static void cb_line_change (cpp_reader *, const cpp_token *, int); + static void cb_define (cpp_reader *, source_location, cpp_hashnode *); + static void cb_undef (cpp_reader *, source_location, cpp_hashnode *); + static void cb_def_pragma (cpp_reader *, source_location); + static void cb_include (cpp_reader *, source_location, const unsigned char *, + const char *, int, const cpp_token **); + static void cb_ident (cpp_reader *, source_location, const cpp_string *); + static void cb_used_define (cpp_reader *, source_location, cpp_hashnode *); + static void cb_used_undef (cpp_reader *, source_location, cpp_hashnode *); + void pp_dir_change (cpp_reader *, const char *); + + static int dump_macro (cpp_reader *, cpp_hashnode *, void *); + static void dump_queued_macros (cpp_reader *); + + + static void + cpp_define_builtins (cpp_reader *pfile) + { + int major, minor, patchlevel; + + /* Initialize CPP built-ins; '1' corresponds to 'flag_hosted' + in C, defines __STDC_HOSTED__?! */ + cpp_init_builtins (pfile, 0); + + /* Initialize GFORTRAN specific builtins. + These are documented. */ + if (sscanf (BASEVER, "%d.%d.%d", &major, &minor, &patchlevel) != 3) + { + sscanf (BASEVER, "%d.%d", &major, &minor); + patchlevel = 0; + } + cpp_define_formatted (pfile, "__GNUC__=%d", major); + cpp_define_formatted (pfile, "__GNUC_MINOR__=%d", minor); + cpp_define_formatted (pfile, "__GNUC_PATCHLEVEL__=%d", patchlevel); + + cpp_define (pfile, "__GFORTRAN__=1"); + cpp_define (pfile, "_LANGUAGE_FORTRAN=1"); + + if (gfc_option.flag_openmp) + cpp_define (pfile, "_OPENMP=200805"); + + + /* More builtins that might be useful, but are not documented + (in no particular order). */ + cpp_define_formatted (pfile, "__VERSION__=\"%s\"", version_string); + + if (flag_pic) + { + cpp_define_formatted (pfile, "__pic__=%d", flag_pic); + cpp_define_formatted (pfile, "__PIC__=%d", flag_pic); + } + if (flag_pie) + { + cpp_define_formatted (pfile, "__pie__=%d", flag_pie); + cpp_define_formatted (pfile, "__PIE__=%d", flag_pie); + } + + if (optimize_size) + cpp_define (pfile, "__OPTIMIZE_SIZE__"); + if (optimize) + cpp_define (pfile, "__OPTIMIZE__"); + + if (fast_math_flags_set_p ()) + cpp_define (pfile, "__FAST_MATH__"); + if (flag_signaling_nans) + cpp_define (pfile, "__SUPPORT_SNAN__"); + + cpp_define_formatted (pfile, "__FINITE_MATH_ONLY__=%d", flag_finite_math_only); + + /* Definitions for LP64 model. */ + if (TYPE_PRECISION (long_integer_type_node) == 64 + && POINTER_SIZE == 64 + && TYPE_PRECISION (integer_type_node) == 32) + { + cpp_define (pfile, "_LP64"); + cpp_define (pfile, "__LP64__"); + } + + /* Define NAME with value TYPE size_unit. + The C-side also defines __SIZEOF_WCHAR_T__, __SIZEOF_WINT_T__ + __SIZEOF_PTRDIFF_T__, however, fortran seems to lack the + appropriate type nodes. */ + + #define define_type_sizeof(NAME, TYPE) \ + cpp_define_formatted (pfile, NAME"="HOST_WIDE_INT_PRINT_DEC, \ + tree_low_cst (TYPE_SIZE_UNIT (TYPE), 1)) + + define_type_sizeof ("__SIZEOF_INT__", integer_type_node); + define_type_sizeof ("__SIZEOF_LONG__", long_integer_type_node); + define_type_sizeof ("__SIZEOF_LONG_LONG__", long_long_integer_type_node); + define_type_sizeof ("__SIZEOF_SHORT__", short_integer_type_node); + define_type_sizeof ("__SIZEOF_FLOAT__", float_type_node); + define_type_sizeof ("__SIZEOF_DOUBLE__", double_type_node); + define_type_sizeof ("__SIZEOF_LONG_DOUBLE__", long_double_type_node); + define_type_sizeof ("__SIZEOF_SIZE_T__", size_type_node); + + #undef define_type_sizeof + + /* The defines below are necessary for the TARGET_* macros. + + FIXME: Note that builtin_define_std() actually is a function + in c-cppbuiltin.c which uses flags undefined for Fortran. + Let's skip this for now. If needed, one needs to look into it + once more. */ + + # define builtin_define(TXT) cpp_define (pfile, TXT) + # define builtin_define_std(TXT) + # define builtin_assert(TXT) cpp_assert (pfile, TXT) + + /* FIXME: Pandora's Box + Using the macros below results in multiple breakages: + - mingw will fail to compile this file as dependent macros + assume to be used in c-cppbuiltin.c only. Further, they use + flags only valid/defined in C (same as noted above). + [config/i386/mingw32.h, config/i386/cygming.h] + - other platforms (not as popular) break similarly + [grep for 'builtin_define_with_int_value' in gcc/config/] + + TARGET_CPU_CPP_BUILTINS (); + TARGET_OS_CPP_BUILTINS (); + TARGET_OBJFMT_CPP_BUILTINS (); */ + + #undef builtin_define + #undef builtin_define_std + #undef builtin_assert + } + + bool + gfc_cpp_enabled (void) + { + return gfc_cpp_option.temporary_filename != NULL; + } + + bool + gfc_cpp_preprocess_only (void) + { + return gfc_cpp_option.preprocess_only; + } + + const char * + gfc_cpp_temporary_file (void) + { + return gfc_cpp_option.temporary_filename; + } + + void + gfc_cpp_init_options (unsigned int argc, + const char **argv ATTRIBUTE_UNUSED) + { + /* Do not create any objects from libcpp here. If no + preprocessing is requested, this would be wasted + time and effort. + + See gfc_cpp_post_options() instead. */ + + gfc_cpp_option.temporary_filename = NULL; + gfc_cpp_option.output_filename = NULL; + gfc_cpp_option.preprocess_only = 0; + gfc_cpp_option.discard_comments = 1; + gfc_cpp_option.discard_comments_in_macro_exp = 1; + gfc_cpp_option.print_include_names = 0; + gfc_cpp_option.no_line_commands = 0; + gfc_cpp_option.dump_macros = '\0'; + gfc_cpp_option.dump_includes = 0; + gfc_cpp_option.working_directory = -1; + gfc_cpp_option.no_predefined = 0; + gfc_cpp_option.standard_include_paths = 1; + gfc_cpp_option.verbose = 0; + + gfc_cpp_option.multilib = NULL; + gfc_cpp_option.prefix = NULL; + gfc_cpp_option.sysroot = NULL; + + gfc_cpp_option.deferred_opt = XNEWVEC (gfc_cpp_deferred_opt_t, argc); + gfc_cpp_option.deferred_opt_count = 0; + } + + int + gfc_cpp_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED) + { + int result = 1; + enum opt_code code = (enum opt_code) scode; + + switch (code) + { + default: + result = 0; + break; + + case OPT_cpp: + gfc_cpp_option.temporary_filename = arg; + break; + + case OPT_nocpp: + gfc_cpp_option.temporary_filename = 0L; + break; + + case OPT_d: + for ( ; *arg; ++arg) + switch (*arg) + { + case 'D': + case 'M': + case 'N': + case 'U': + gfc_cpp_option.dump_macros = *arg; + break; + + case 'I': + gfc_cpp_option.dump_includes = 1; + break; + } + break; + + case OPT_fworking_directory: + gfc_cpp_option.working_directory = value; + break; + + case OPT_idirafter: + gfc_cpp_add_include_path_after (xstrdup(arg), true); + break; + + case OPT_imultilib: + gfc_cpp_option.multilib = arg; + break; + + case OPT_iprefix: + gfc_cpp_option.prefix = arg; + break; + + case OPT_isysroot: + gfc_cpp_option.sysroot = arg; + break; + + case OPT_iquote: + case OPT_isystem: + gfc_cpp_add_include_path (xstrdup(arg), true); + break; + + case OPT_nostdinc: + gfc_cpp_option.standard_include_paths = value; + break; + + case OPT_o: + if (!gfc_cpp_option.output_filename) + gfc_cpp_option.output_filename = arg; + else + gfc_fatal_error ("output filename specified twice"); + break; + + case OPT_undef: + gfc_cpp_option.no_predefined = value; + break; + + case OPT_v: + gfc_cpp_option.verbose = value; + break; + + case OPT_A: + case OPT_D: + case OPT_U: + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code; + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg; + gfc_cpp_option.deferred_opt_count++; + break; + + case OPT_C: + gfc_cpp_option.discard_comments = 0; + break; + + case OPT_CC: + gfc_cpp_option.discard_comments = 0; + gfc_cpp_option.discard_comments_in_macro_exp = 0; + break; + + case OPT_E: + gfc_cpp_option.preprocess_only = 1; + break; + + case OPT_H: + gfc_cpp_option.print_include_names = 1; + break; + + case OPT_P: + gfc_cpp_option.no_line_commands = 1; + break; + } + + return result; + } + + + void + gfc_cpp_post_options (void) + { + /* Any preprocessing-related option without '-cpp' is considered + an error. */ + if (!gfc_cpp_enabled () + && (gfc_cpp_preprocess_only () + || !gfc_cpp_option.discard_comments + || !gfc_cpp_option.discard_comments_in_macro_exp + || gfc_cpp_option.print_include_names + || gfc_cpp_option.no_line_commands + || gfc_cpp_option.dump_macros + || gfc_cpp_option.dump_includes)) + gfc_fatal_error("To enable preprocessing, use -cpp"); + + cpp_in = cpp_create_reader (CLK_GNUC89, NULL, line_table); + if (!gfc_cpp_enabled()) + return; + + gcc_assert (cpp_in); + + /* The cpp_options-structure defines far more flags than those set here. + If any other is implemented, see c-opt.c (sanitize_cpp_opts) for + inter-option dependencies that may need to be enforced. */ + cpp_option = cpp_get_options (cpp_in); + gcc_assert (cpp_option); + + /* TODO: allow non-traditional modes, e.g. by -cpp-std=...? */ + cpp_option->traditional = 1; + cpp_option->cplusplus_comments = 0; + + cpp_option->pedantic = pedantic; + cpp_option->inhibit_warnings = inhibit_warnings; + + cpp_option->dollars_in_ident = gfc_option.flag_dollar_ok; + cpp_option->discard_comments = gfc_cpp_option.discard_comments; + cpp_option->discard_comments_in_macro_exp = gfc_cpp_option.discard_comments_in_macro_exp; + cpp_option->print_include_names = gfc_cpp_option.print_include_names; + cpp_option->preprocessed = gfc_option.flag_preprocessed; + + if (gfc_cpp_option.working_directory == -1) + gfc_cpp_option.working_directory = (debug_info_level != DINFO_LEVEL_NONE); + + cpp_post_options (cpp_in); + + /* If an error has occurred in cpplib, note it so we fail immediately. */ + errorcount += cpp_errors (cpp_in); + + gfc_cpp_register_include_paths (); + } + + + void + gfc_cpp_init_0 (void) + { + struct cpp_callbacks *cb; + + cb = cpp_get_callbacks (cpp_in); + cb->file_change = cb_file_change; + cb->line_change = cb_line_change; + cb->ident = cb_ident; + cb->def_pragma = cb_def_pragma; + + if (gfc_cpp_option.dump_includes) + cb->include = cb_include; + + if ((gfc_cpp_option.dump_macros == 'D') + || (gfc_cpp_option.dump_macros == 'N')) + { + cb->define = cb_define; + cb->undef = cb_undef; + } + + if (gfc_cpp_option.dump_macros == 'U') + { + cb->before_define = dump_queued_macros; + cb->used_define = cb_used_define; + cb->used_undef = cb_used_undef; + } + + /* Initialize the print structure. Setting print.src_line to -1 here is + a trick to guarantee that the first token of the file will cause + a linemarker to be output by maybe_print_line. */ + print.src_line = -1; + print.printed = 0; + print.prev = 0; + print.first_time = 1; + + if (gfc_cpp_preprocess_only ()) + { + if (gfc_cpp_option.output_filename) + { + /* This needs cheating: with "-E -o ", the user wants the + preprocessed output in . However, if nothing is done + about it is also used for assembler output. Hence, it + is necessary to redirect assembler output (actually nothing + as -E implies -fsyntax-only) to another file, otherwise the + output from preprocessing is lost. */ + asm_file_name = gfc_cpp_option.temporary_filename; + + print.outf = fopen (gfc_cpp_option.output_filename, "w"); + if (print.outf == NULL) + gfc_fatal_error ("opening output file %s: %s", + gfc_cpp_option.output_filename, strerror(errno)); + } + else + print.outf = stdout; + } + else + { + print.outf = fopen (gfc_cpp_option.temporary_filename, "w"); + if (print.outf == NULL) + gfc_fatal_error ("opening output file %s: %s", + gfc_cpp_option.temporary_filename, strerror(errno)); + } + + gcc_assert(cpp_in); + if (!cpp_read_main_file (cpp_in, gfc_source_file)) + errorcount++; + } + + void + gfc_cpp_init (void) + { + int i; + + if (gfc_option.flag_preprocessed) + return; + + cpp_change_file (cpp_in, LC_RENAME, _("")); + if (!gfc_cpp_option.no_predefined) + cpp_define_builtins (cpp_in); + + /* Handle deferred options from command-line. */ + cpp_change_file (cpp_in, LC_RENAME, _("")); + + for (i = 0; i < gfc_cpp_option.deferred_opt_count; i++) + { + gfc_cpp_deferred_opt_t *opt = &gfc_cpp_option.deferred_opt[i]; + + if (opt->code == OPT_D) + cpp_define (cpp_in, opt->arg); + else if (opt->code == OPT_U) + cpp_undef (cpp_in, opt->arg); + else if (opt->code == OPT_A) + { + if (opt->arg[0] == '-') + cpp_unassert (cpp_in, opt->arg + 1); + else + cpp_assert (cpp_in, opt->arg); + } + } + + if (gfc_cpp_option.working_directory + && gfc_cpp_option.preprocess_only && !gfc_cpp_option.no_line_commands) + pp_dir_change (cpp_in, get_src_pwd ()); + } + + gfc_try + gfc_cpp_preprocess (const char *source_file) + { + if (!gfc_cpp_enabled ()) + return FAILURE; + + cpp_change_file (cpp_in, LC_RENAME, source_file); + + if (cpp_option->traditional) + scan_translation_unit_trad (cpp_in); + else + scan_translation_unit (cpp_in); + + /* -dM command line option. */ + if (gfc_cpp_preprocess_only () && + gfc_cpp_option.dump_macros == 'M') + { + putc ('\n', print.outf); + cpp_forall_identifiers (cpp_in, dump_macro, NULL); + } + + putc ('\n', print.outf); + + if (!gfc_cpp_preprocess_only () + || (gfc_cpp_preprocess_only () && gfc_cpp_option.output_filename)) + fclose (print.outf); + + return SUCCESS; + } + + void + gfc_cpp_done (void) + { + if (!gfc_cpp_enabled ()) + return; + + /* TODO: if dependency tracking was enabled, call + cpp_finish() here to write dependencies. + + Use cpp_get_deps() to access the current source's + dependencies during parsing. Add dependencies using + the mkdeps-interface (defined in libcpp). */ + + gcc_assert (cpp_in); + cpp_undef_all (cpp_in); + cpp_clear_file_cache (cpp_in); + } + + /* PATH must be malloc-ed and NULL-terminated. */ + void + gfc_cpp_add_include_path (char *path, bool user_supplied) + { + /* CHAIN sets cpp_dir->sysp which differs from 0 if PATH is a system + include path. Fortran does not define any system include paths. */ + int cxx_aware = 0; + + add_path (path, BRACKET, cxx_aware, user_supplied); + } + + void + gfc_cpp_add_include_path_after (char *path, bool user_supplied) + { + int cxx_aware = 0; + add_path (path, AFTER, cxx_aware, user_supplied); + } + + void + gfc_cpp_register_include_paths (void) + { + int cxx_stdinc = 0; + register_include_chains (cpp_in, gfc_cpp_option.sysroot, + gfc_cpp_option.prefix, gfc_cpp_option.multilib, + gfc_cpp_option.standard_include_paths, cxx_stdinc, + gfc_cpp_option.verbose); + } + + + + static void scan_translation_unit_trad (cpp_reader *); + static void account_for_newlines (const unsigned char *, size_t); + static int dump_macro (cpp_reader *, cpp_hashnode *, void *); + + static void print_line (source_location, const char *); + static void maybe_print_line (source_location); + + + /* Writes out the preprocessed file, handling spacing and paste + avoidance issues. */ + static void + scan_translation_unit (cpp_reader *pfile) + { + bool avoid_paste = false; + + print.source = NULL; + for (;;) + { + const cpp_token *token = cpp_get_token (pfile); + + if (token->type == CPP_PADDING) + { + avoid_paste = true; + if (print.source == NULL + || (!(print.source->flags & PREV_WHITE) + && token->val.source == NULL)) + print.source = token->val.source; + continue; + } + + if (token->type == CPP_EOF) + break; + + /* Subtle logic to output a space if and only if necessary. */ + if (avoid_paste) + { + if (print.source == NULL) + print.source = token; + if (print.source->flags & PREV_WHITE + || (print.prev + && cpp_avoid_paste (pfile, print.prev, token)) + || (print.prev == NULL && token->type == CPP_HASH)) + putc (' ', print.outf); + } + else if (token->flags & PREV_WHITE) + putc (' ', print.outf); + + avoid_paste = false; + print.source = NULL; + print.prev = token; + cpp_output_token (token, print.outf); + + if (token->type == CPP_COMMENT) + account_for_newlines (token->val.str.text, token->val.str.len); + } + } + + /* Adjust print.src_line for newlines embedded in output. */ + static void + account_for_newlines (const unsigned char *str, size_t len) + { + while (len--) + if (*str++ == '\n') + print.src_line++; + } + + /* Writes out a traditionally preprocessed file. */ + static void + scan_translation_unit_trad (cpp_reader *pfile) + { + while (_cpp_read_logical_line_trad (pfile)) + { + size_t len = pfile->out.cur - pfile->out.base; + maybe_print_line (pfile->out.first_line); + fwrite (pfile->out.base, 1, len, print.outf); + print.printed = 1; + if (!CPP_OPTION (pfile, discard_comments)) + account_for_newlines (pfile->out.base, len); + } + } + + /* If the token read on logical line LINE needs to be output on a + different line to the current one, output the required newlines or + a line marker. */ + static void + maybe_print_line (source_location src_loc) + { + const struct line_map *map = linemap_lookup (line_table, src_loc); + int src_line = SOURCE_LINE (map, src_loc); + + /* End the previous line of text. */ + if (print.printed) + { + putc ('\n', print.outf); + print.src_line++; + print.printed = 0; + } + + if (src_line >= print.src_line && src_line < print.src_line + 8) + { + while (src_line > print.src_line) + { + putc ('\n', print.outf); + print.src_line++; + } + } + else + print_line (src_loc, ""); + } + + /* Output a line marker for logical line LINE. Special flags are "1" + or "2" indicating entering or leaving a file. */ + static void + print_line (source_location src_loc, const char *special_flags) + { + /* End any previous line of text. */ + if (print.printed) + putc ('\n', print.outf); + print.printed = 0; + + if (!gfc_cpp_option.no_line_commands) + { + const struct line_map *map = linemap_lookup (line_table, src_loc); + + size_t to_file_len = strlen (map->to_file); + unsigned char *to_file_quoted = + (unsigned char *) alloca (to_file_len * 4 + 1); + unsigned char *p; + + print.src_line = SOURCE_LINE (map, src_loc); + + /* cpp_quote_string does not nul-terminate, so we have to do it + ourselves. */ + p = cpp_quote_string (to_file_quoted, + (const unsigned char *) map->to_file, to_file_len); + *p = '\0'; + fprintf (print.outf, "# %u \"%s\"%s", + print.src_line == 0 ? 1 : print.src_line, + to_file_quoted, special_flags); + + if (map->sysp == 2) + fputs (" 3 4", print.outf); + else if (map->sysp == 1) + fputs (" 3", print.outf); + + putc ('\n', print.outf); + } + } + + static void + cb_file_change (cpp_reader * ARG_UNUSED (pfile), const struct line_map *map) + { + const char *flags = ""; + + if (gfc_cpp_option.no_line_commands) + return; + + if (!map) + return; + + if (print.first_time) + { + /* Avoid printing foo.i when the main file is foo.c. */ + if (!cpp_get_options (cpp_in)->preprocessed) + print_line (map->start_location, flags); + print.first_time = 0; + } + else + { + /* Bring current file to correct line when entering a new file. */ + if (map->reason == LC_ENTER) + { + const struct line_map *from = INCLUDED_FROM (line_table, map); + maybe_print_line (LAST_SOURCE_LINE_LOCATION (from)); + } + if (map->reason == LC_ENTER) + flags = " 1"; + else if (map->reason == LC_LEAVE) + flags = " 2"; + print_line (map->start_location, flags); + } + + } + + /* Called when a line of output is started. TOKEN is the first token + of the line, and at end of file will be CPP_EOF. */ + static void + cb_line_change (cpp_reader *pfile, const cpp_token *token, + int parsing_args) + { + source_location src_loc = token->src_loc; + + if (token->type == CPP_EOF || parsing_args) + return; + + maybe_print_line (src_loc); + print.prev = 0; + print.source = 0; + + /* Supply enough spaces to put this token in its original column, + one space per column greater than 2, since scan_translation_unit + will provide a space if PREV_WHITE. Don't bother trying to + reconstruct tabs; we can't get it right in general, and nothing + ought to care. Some things do care; the fault lies with them. */ + if (!CPP_OPTION (pfile, traditional)) + { + const struct line_map *map = linemap_lookup (line_table, src_loc); + int spaces = SOURCE_COLUMN (map, src_loc) - 2; + print.printed = 1; + + while (-- spaces >= 0) + putc (' ', print.outf); + } + } + + static void + cb_ident (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + const cpp_string *str) + { + maybe_print_line (line); + fprintf (print.outf, "#ident %s\n", str->text); + print.src_line++; + } + + static void + cb_define (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + cpp_hashnode *node ATTRIBUTE_UNUSED) + { + maybe_print_line (line); + fputs ("#define ", print.outf); + + /* 'D' is whole definition; 'N' is name only. */ + if (gfc_cpp_option.dump_macros == 'D') + fputs ((const char *) cpp_macro_definition (pfile, node), + print.outf); + else + fputs ((const char *) NODE_NAME (node), print.outf); + + putc ('\n', print.outf); + if (linemap_lookup (line_table, line)->to_line != 0) + print.src_line++; + } + + static void + cb_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + cpp_hashnode *node) + { + maybe_print_line (line); + fprintf (print.outf, "#undef %s\n", NODE_NAME (node)); + print.src_line++; + } + + static void + cb_include (cpp_reader *pfile ATTRIBUTE_UNUSED, source_location line, + const unsigned char *dir, const char *header, int angle_brackets, + const cpp_token **comments) + { + maybe_print_line (line); + if (angle_brackets) + fprintf (print.outf, "#%s <%s>", dir, header); + else + fprintf (print.outf, "#%s \"%s\"", dir, header); + + if (comments != NULL) + { + while (*comments != NULL) + { + if ((*comments)->flags & PREV_WHITE) + putc (' ', print.outf); + cpp_output_token (*comments, print.outf); + ++comments; + } + } + + putc ('\n', print.outf); + print.src_line++; + } + + /* Dump out the hash table. */ + static int + dump_macro (cpp_reader *pfile, cpp_hashnode *node, void *v ATTRIBUTE_UNUSED) + { + if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)) + { + fputs ("#define ", print.outf); + fputs ((const char *) cpp_macro_definition (pfile, node), + print.outf); + putc ('\n', print.outf); + print.src_line++; + } + + return 1; + } + + static void + cb_used_define (cpp_reader *pfile, source_location line ATTRIBUTE_UNUSED, + cpp_hashnode *node) + { + gfc_cpp_macro_queue *q; + q = XNEW (gfc_cpp_macro_queue); + q->macro = xstrdup ((const char *) cpp_macro_definition (pfile, node)); + q->next = cpp_define_queue; + cpp_define_queue = q; + } + + + /* Callback called when -fworking-director and -E to emit working + directory in cpp output file. */ + + void + pp_dir_change (cpp_reader *pfile ATTRIBUTE_UNUSED, const char *dir) + { + size_t to_file_len = strlen (dir); + unsigned char *to_file_quoted = + (unsigned char *) alloca (to_file_len * 4 + 1); + unsigned char *p; + + /* cpp_quote_string does not nul-terminate, so we have to do it ourselves. */ + p = cpp_quote_string (to_file_quoted, (const unsigned char *) dir, to_file_len); + *p = '\0'; + fprintf (print.outf, "# 1 \"%s//\"\n", to_file_quoted); + } + + /* Copy a #pragma directive to the preprocessed output. */ + static void + cb_def_pragma (cpp_reader *pfile, source_location line) + { + maybe_print_line (line); + fputs ("#pragma ", print.outf); + cpp_output_line (pfile, print.outf); + print.src_line++; + } + + static void + cb_used_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, + source_location line ATTRIBUTE_UNUSED, + cpp_hashnode *node) + { + gfc_cpp_macro_queue *q; + q = XNEW (gfc_cpp_macro_queue); + q->macro = xstrdup ((const char *) NODE_NAME (node)); + q->next = cpp_undefine_queue; + cpp_undefine_queue = q; + } + + static void + dump_queued_macros (cpp_reader *pfile ATTRIBUTE_UNUSED) + { + gfc_cpp_macro_queue *q; + + /* End the previous line of text. */ + if (print.printed) + { + putc ('\n', print.outf); + print.src_line++; + print.printed = 0; + } + + for (q = cpp_define_queue; q;) + { + gfc_cpp_macro_queue *oq; + fputs ("#define ", print.outf); + fputs (q->macro, print.outf); + putc ('\n', print.outf); + print.src_line++; + oq = q; + q = q->next; + gfc_free (oq->macro); + gfc_free (oq); + } + cpp_define_queue = NULL; + for (q = cpp_undefine_queue; q;) + { + gfc_cpp_macro_queue *oq; + fprintf (print.outf, "#undef %s\n", q->macro); + print.src_line++; + oq = q; + q = q->next; + gfc_free (oq->macro); + gfc_free (oq); + } + cpp_undefine_queue = NULL; + } + + diff -Nrcpad gcc-4.3.3/gcc/fortran/cpp.h gcc-4.4.0/gcc/fortran/cpp.h *** gcc-4.3.3/gcc/fortran/cpp.h Thu Jan 1 00:00:00 1970 --- gcc-4.4.0/gcc/fortran/cpp.h Tue Dec 9 19:25:55 2008 *************** *** 0 **** --- 1,48 ---- + /* Copyright (C) 2008 Free Software Foundation, Inc. + + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 3, or (at your option) any later + version. + + GCC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + + #ifndef GFC_CPP_H + #define GFC_CPP_H + + /* Returns true if preprocessing is enabled, false otherwise. */ + bool gfc_cpp_enabled (void); + + bool gfc_cpp_preprocess_only (void); + + const char *gfc_cpp_temporary_file (void); + + + void gfc_cpp_init_0 (void); + void gfc_cpp_init (void); + + void gfc_cpp_init_options (unsigned int argc, const char **argv); + + int gfc_cpp_handle_option(size_t scode, const char *arg, int value); + + void gfc_cpp_post_options (void); + + gfc_try gfc_cpp_preprocess (const char *source_file); + + void gfc_cpp_done (void); + + void gfc_cpp_add_include_path (char *path, bool user_supplied); + void gfc_cpp_add_include_path_after (char *path, bool user_supplied); + + void gfc_cpp_register_include_paths (void); + + #endif /* GFC_CPP_H */ diff -Nrcpad gcc-4.3.3/gcc/fortran/data.c gcc-4.4.0/gcc/fortran/data.c *** gcc-4.3.3/gcc/fortran/data.c Tue Feb 5 20:40:45 2008 --- gcc-4.4.0/gcc/fortran/data.c Tue Jul 29 00:45:52 2008 *************** *** 1,5 **** /* Supporting functions for resolving DATA statement. ! Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Lifang Zeng --- 1,5 ---- /* Supporting functions for resolving DATA statement. ! Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Lifang Zeng *************** along with GCC; see the file COPYING3. *** 23,29 **** /* Notes for DATA statement implementation: We first assign initial value to each symbol by gfc_assign_data_value ! during resolveing DATA statement. Refer to check_data_variable and traverse_data_list in resolve.c. The complexity exists in the handling of array section, implied do --- 23,29 ---- /* Notes for DATA statement implementation: We first assign initial value to each symbol by gfc_assign_data_value ! during resolving DATA statement. Refer to check_data_variable and traverse_data_list in resolve.c. The complexity exists in the handling of array section, implied do *************** get_array_index (gfc_array_ref *ar, mpz_ *** 46,52 **** { gfc_expr *e; int i; ! try re; mpz_t delta; mpz_t tmp; --- 46,52 ---- { gfc_expr *e; int i; ! gfc_try re; mpz_t delta; mpz_t tmp; *************** find_con_by_component (gfc_component *co *** 144,160 **** /* Create a character type initialization expression from RVALUE. TS [and REF] describe [the substring of] the variable being initialized. ! INIT is thh existing initializer, not NULL. Initialization is performed according to normal assignment rules. */ static gfc_expr * create_character_intializer (gfc_expr *init, gfc_typespec *ts, gfc_ref *ref, gfc_expr *rvalue) { ! int len; ! int start; ! int end; ! char *dest, *rvalue_string; gfc_extract_int (ts->cl->length, &len); --- 144,158 ---- /* Create a character type initialization expression from RVALUE. TS [and REF] describe [the substring of] the variable being initialized. ! INIT is the existing initializer, not NULL. Initialization is performed according to normal assignment rules. */ static gfc_expr * create_character_intializer (gfc_expr *init, gfc_typespec *ts, gfc_ref *ref, gfc_expr *rvalue) { ! int len, start, end; ! gfc_char_t *dest; gfc_extract_int (ts->cl->length, &len); *************** create_character_intializer (gfc_expr *i *** 165,177 **** 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. */ if (ref != NULL) ! memset (dest, ' ', len); } else dest = init->value.character.string; --- 163,175 ---- init->expr_type = EXPR_CONSTANT; init->ts = *ts; ! dest = gfc_get_wide_string (len + 1); dest[len] = '\0'; init->value.character.length = len; init->value.character.string = dest; /* Blank the string if we're only setting a substring. */ if (ref != NULL) ! gfc_wide_memset (dest, ' ', len); } else dest = init->value.character.string; *************** create_character_intializer (gfc_expr *i *** 208,222 **** /* Copy the initial value. */ if (rvalue->ts.type == BT_HOLLERITH) ! { ! len = rvalue->representation.length; ! rvalue_string = rvalue->representation.string; ! } else ! { ! len = rvalue->value.character.length; ! rvalue_string = rvalue->value.character.string; ! } if (len > end - start) { --- 206,214 ---- /* Copy the initial value. */ if (rvalue->ts.type == BT_HOLLERITH) ! len = rvalue->representation.length; else ! len = rvalue->value.character.length; if (len > end - start) { *************** create_character_intializer (gfc_expr *i *** 225,240 **** "at %L", &rvalue->where); } ! memcpy (&dest[start], rvalue_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->representation.length = init->value.character.length; ! init->representation.string = init->value.character.string; } return init; --- 217,242 ---- "at %L", &rvalue->where); } ! if (rvalue->ts.type == BT_HOLLERITH) ! { ! int i; ! for (i = 0; i < len; i++) ! dest[start+i] = rvalue->representation.string[i]; ! } ! else ! memcpy (&dest[start], rvalue->value.character.string, ! len * sizeof (gfc_char_t)); /* Pad with spaces. Substrings will already be blanked. */ if (len < end - start && ref == NULL) ! gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); if (rvalue->ts.type == BT_HOLLERITH) { init->representation.length = init->value.character.length; ! init->representation.string ! = gfc_widechar_to_char (init->value.character.string, ! init->value.character.length); } return init; *************** create_character_intializer (gfc_expr *i *** 245,251 **** LVALUE already has an initialization, we extend this, otherwise we create a new one. */ ! try gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) { gfc_ref *ref; --- 247,253 ---- LVALUE already has an initialization, we extend this, otherwise we create a new one. */ ! gfc_try gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) { gfc_ref *ref; *************** gfc_assign_data_value (gfc_expr *lvalue, *** 424,437 **** /* Order in which the expressions arrive here depends on whether they are from data statements or F95 style declarations. Therefore, check which is the most recent. */ - #ifdef USE_MAPPED_LOCATION expr = (LOCATION_LINE (init->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? init : rvalue; - #else - expr = (init->where.lb->linenum > rvalue->where.lb->linenum) - ? init : rvalue; - #endif gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization " "of '%s' at %L", symbol->name, &expr->where); } --- 426,434 ---- *************** formalize_structure_cons (gfc_expr *expr *** 757,763 **** } ! /* Make sure an initialization expression is in normalized form. Ie. all elements of the constructors are in the correct order. */ static void --- 754,760 ---- } ! /* Make sure an initialization expression is in normalized form, i.e., all elements of the constructors are in the correct order. */ static void diff -Nrcpad gcc-4.3.3/gcc/fortran/data.h gcc-4.4.0/gcc/fortran/data.h *** gcc-4.3.3/gcc/fortran/data.h Fri Oct 5 12:33:07 2007 --- gcc-4.4.0/gcc/fortran/data.h Tue Jul 29 00:45:52 2008 *************** *** 1,5 **** /* Header for functions resolving DATA statements. ! Copyright (C) 2007 Free Software Foundation, Inc. This file is part of GCC. --- 1,5 ---- /* Header for functions resolving DATA statements. ! Copyright (C) 2007, 2008 Free Software Foundation, Inc. This file is part of GCC. *************** along with GCC; see the file COPYING3. *** 19,24 **** void gfc_formalize_init_value (gfc_symbol *); void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *); ! try gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t); void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t); void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *); --- 19,24 ---- void gfc_formalize_init_value (gfc_symbol *); void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *); ! gfc_try gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t); void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t); void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *); diff -Nrcpad gcc-4.3.3/gcc/fortran/decl.c gcc-4.4.0/gcc/fortran/decl.c *** gcc-4.3.3/gcc/fortran/decl.c Wed Sep 24 08:04:26 2008 --- gcc-4.4.0/gcc/fortran/decl.c Tue Dec 2 11:58:16 2008 *************** *** 1,5 **** /* Declaration statement matcher ! Copyright (C) 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught --- 1,5 ---- /* Declaration statement matcher ! Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Andy Vaught *************** along with GCC; see the file COPYING3. *** 28,36 **** /* Macros to access allocate memory for gfc_data_variable, gfc_data_value and gfc_data. */ ! #define gfc_get_data_variable() gfc_getmem (sizeof (gfc_data_variable)) ! #define gfc_get_data_value() gfc_getmem (sizeof (gfc_data_value)) ! #define gfc_get_data() gfc_getmem( sizeof (gfc_data)) /* This flag is set if an old-style length selector is matched --- 28,36 ---- /* Macros to access allocate memory for gfc_data_variable, gfc_data_value and gfc_data. */ ! #define gfc_get_data_variable() XCNEW (gfc_data_variable) ! #define gfc_get_data_value() XCNEW (gfc_data_value) ! #define gfc_get_data() XCNEW (gfc_data) /* This flag is set if an old-style length selector is matched *************** syntax: *** 231,251 **** variable-iterator list. */ static match ! var_element (gfc_data_variable *new) { match m; gfc_symbol *sym; ! memset (new, 0, sizeof (gfc_data_variable)); if (gfc_match_char ('(') == MATCH_YES) ! return var_list (new); ! m = gfc_match_variable (&new->expr, 0); if (m != MATCH_YES) return m; ! sym = new->expr->symtree->n.sym; if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns) --- 231,256 ---- variable-iterator list. */ static match ! var_element (gfc_data_variable *new_var) { match m; gfc_symbol *sym; ! memset (new_var, 0, sizeof (gfc_data_variable)); if (gfc_match_char ('(') == MATCH_YES) ! return var_list (new_var); ! m = gfc_match_variable (&new_var->expr, 0); if (m != MATCH_YES) return m; ! sym = new_var->expr->symtree->n.sym; ! ! /* Symbol should already have an associated type. */ ! if (gfc_check_symbol_typed (sym, gfc_current_ns, ! false, gfc_current_locus) == FAILURE) ! return MATCH_ERROR; if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns) *************** var_element (gfc_data_variable *new) *** 262,268 **** sym->name) == FAILURE) return MATCH_ERROR; ! if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE) return MATCH_ERROR; return MATCH_YES; --- 267,273 ---- sym->name) == FAILURE) return MATCH_ERROR; ! if (gfc_add_data (&sym->attr, sym->name, &new_var->expr->where) == FAILURE) return MATCH_ERROR; return MATCH_YES; *************** var_element (gfc_data_variable *new) *** 274,280 **** static match top_var_list (gfc_data *d) { ! gfc_data_variable var, *tail, *new; match m; tail = NULL; --- 279,285 ---- static match top_var_list (gfc_data *d) { ! gfc_data_variable var, *tail, *new_var; match m; tail = NULL; *************** top_var_list (gfc_data *d) *** 287,301 **** if (m == MATCH_ERROR) return MATCH_ERROR; ! new = gfc_get_data_variable (); ! *new = var; if (tail == NULL) ! d->var = new; else ! tail->next = new; ! tail = new; if (gfc_match_char ('/') == MATCH_YES) break; --- 292,306 ---- if (m == MATCH_ERROR) return MATCH_ERROR; ! new_var = gfc_get_data_variable (); ! *new_var = var; if (tail == NULL) ! d->var = new_var; else ! tail->next = new_var; ! tail = new_var; if (gfc_match_char ('/') == MATCH_YES) break; *************** match_data_constant (gfc_expr **result) *** 367,373 **** return MATCH_ERROR; } else if (sym->attr.flavor == FL_DERIVED) ! return gfc_match_structure_constructor (sym, result); /* Check to see if the value is an initialization array expression. */ if (sym->value->expr_type == EXPR_ARRAY) --- 372,378 ---- return MATCH_ERROR; } else if (sym->attr.flavor == FL_DERIVED) ! return gfc_match_structure_constructor (sym, result, false); /* Check to see if the value is an initialization array expression. */ if (sym->value->expr_type == EXPR_ARRAY) *************** match_data_constant (gfc_expr **result) *** 404,410 **** static match top_val_list (gfc_data *data) { ! gfc_data_value *new, *tail; gfc_expr *expr; match m; --- 409,415 ---- static match top_val_list (gfc_data *data) { ! gfc_data_value *new_val, *tail; gfc_expr *expr; match m; *************** top_val_list (gfc_data *data) *** 418,432 **** if (m == MATCH_ERROR) return MATCH_ERROR; ! new = gfc_get_data_value (); ! mpz_init (new->repeat); if (tail == NULL) ! data->value = new; else ! tail->next = new; ! tail = new; if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) { --- 423,437 ---- if (m == MATCH_ERROR) return MATCH_ERROR; ! new_val = gfc_get_data_value (); ! mpz_init (new_val->repeat); if (tail == NULL) ! data->value = new_val; else ! tail->next = new_val; ! tail = new_val; if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) { *************** match_old_style_init (const char *name) *** 518,543 **** match gfc_match_data (void) { ! gfc_data *new; match m; set_in_match_data (true); for (;;) { ! new = gfc_get_data (); ! new->where = gfc_current_locus; ! m = top_var_list (new); if (m != MATCH_YES) goto cleanup; ! m = top_val_list (new); if (m != MATCH_YES) goto cleanup; ! new->next = gfc_current_ns->data; ! gfc_current_ns->data = new; if (gfc_match_eos () == MATCH_YES) break; --- 523,548 ---- match gfc_match_data (void) { ! gfc_data *new_data; match m; set_in_match_data (true); for (;;) { ! new_data = gfc_get_data (); ! new_data->where = gfc_current_locus; ! m = top_var_list (new_data); if (m != MATCH_YES) goto cleanup; ! m = top_val_list (new_data); if (m != MATCH_YES) goto cleanup; ! new_data->next = gfc_current_ns->data; ! gfc_current_ns->data = new_data; if (gfc_match_eos () == MATCH_YES) break; *************** gfc_match_data (void) *** 557,563 **** cleanup: set_in_match_data (false); ! gfc_free_data (new); return MATCH_ERROR; } --- 562,568 ---- cleanup: set_in_match_data (false); ! gfc_free_data (new_data); return MATCH_ERROR; } *************** char_len_param_value (gfc_expr **expr) *** 598,603 **** --- 603,613 ---- } m = gfc_match_expr (expr); + + if (m == MATCH_YES + && gfc_expr_check_typed (*expr, gfc_current_ns, false) == FAILURE) + return MATCH_ERROR; + if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION) { if ((*expr)->value.function.actual *************** get_proc_name (const char *name, gfc_sym *** 762,768 **** (*result)->ts = sym->ts; /* Put the symbol in the procedure namespace so that, should ! the ENTRY preceed its specification, the specification can be applied. */ (*result)->ns = gfc_current_ns; --- 772,778 ---- (*result)->ts = sym->ts; /* Put the symbol in the procedure namespace so that, should ! the ENTRY precede its specification, the specification can be applied. */ (*result)->ns = gfc_current_ns; *************** get_proc_name (const char *name, gfc_sym *** 781,787 **** sym = *result; gfc_current_ns->refs++; ! if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE) { /* Trap another encompassed procedure with the same name. All these conditions are necessary to avoid picking up an entry --- 791,797 ---- sym = *result; gfc_current_ns->refs++; ! if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE) { /* Trap another encompassed procedure with the same name. All these conditions are necessary to avoid picking up an entry *************** get_proc_name (const char *name, gfc_sym *** 867,877 **** the compiler could have automatically handled the varying sizes across platforms. */ ! try verify_c_interop_param (gfc_symbol *sym) { int is_c_interop = 0; ! try retval = SUCCESS; /* We check implicitly typed variables in symbol.c:gfc_set_default_type(). Don't repeat the checks here. */ --- 877,887 ---- the compiler could have automatically handled the varying sizes across platforms. */ ! gfc_try verify_c_interop_param (gfc_symbol *sym) { int is_c_interop = 0; ! gfc_try retval = SUCCESS; /* We check implicitly typed variables in symbol.c:gfc_set_default_type(). Don't repeat the checks here. */ *************** verify_c_interop_param (gfc_symbol *sym) *** 908,914 **** if (sym->ns->proc_name->attr.is_bind_c == 1) { is_c_interop = ! (verify_c_interop (&(sym->ts), sym->name, &(sym->declared_at)) == SUCCESS ? 1 : 0); if (is_c_interop != 1) --- 918,924 ---- if (sym->ns->proc_name->attr.is_bind_c == 1) { is_c_interop = ! (verify_c_interop (&(sym->ts)) == SUCCESS ? 1 : 0); if (is_c_interop != 1) *************** verify_c_interop_param (gfc_symbol *sym) *** 1009,1015 **** /* Function called by variable_decl() that adds a name to the symbol table. */ ! static try build_sym (const char *name, gfc_charlen *cl, gfc_array_spec **as, locus *var_locus) { --- 1019,1025 ---- /* Function called by variable_decl() that adds a name to the symbol table. */ ! static gfc_try build_sym (const char *name, gfc_charlen *cl, gfc_array_spec **as, locus *var_locus) { *************** build_sym (const char *name, gfc_charlen *** 1084,1107 **** /* Set character constant to the given length. The constant will be padded or ! truncated. */ void ! gfc_set_constant_character_len (int len, gfc_expr *expr, bool array) { ! char *s; int slen; gcc_assert (expr->expr_type == EXPR_CONSTANT); ! gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1); 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); if (gfc_option.warn_character_truncation && slen > len) gfc_warning_now ("CHARACTER expression at %L is being truncated " --- 1094,1120 ---- /* Set character constant to the given length. The constant will be padded or ! truncated. If we're inside an array constructor without a typespec, we ! additionally check that all elements have the same length; check_len -1 ! means no checking. */ void ! gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len) { ! gfc_char_t *s; int slen; gcc_assert (expr->expr_type == EXPR_CONSTANT); ! gcc_assert (expr->ts.type == BT_CHARACTER); slen = expr->value.character.length; if (len != slen) { ! s = gfc_get_wide_string (len + 1); ! memcpy (s, expr->value.character.string, ! MIN (len, slen) * sizeof (gfc_char_t)); if (len > slen) ! gfc_wide_memset (&s[slen], ' ', len - slen); if (gfc_option.warn_character_truncation && slen > len) gfc_warning_now ("CHARACTER expression at %L is being truncated " *************** gfc_set_constant_character_len (int len, *** 1109,1118 **** /* Apply the standard by 'hand' otherwise it gets cleared for initializers. */ ! if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU)) gfc_error_now ("The CHARACTER elements of the array constructor " "at %L must have the same length (%d/%d)", ! &expr->where, slen, len); s[len] = '\0'; gfc_free (expr->value.character.string); --- 1122,1132 ---- /* Apply the standard by 'hand' otherwise it gets cleared for initializers. */ ! if (check_len != -1 && slen != check_len ! && !(gfc_option.allow_std & GFC_STD_GNU)) gfc_error_now ("The CHARACTER elements of the array constructor " "at %L must have the same length (%d/%d)", ! &expr->where, slen, check_len); s[len] = '\0'; gfc_free (expr->value.character.string); *************** create_enum_history (gfc_symbol *sym, gf *** 1136,1142 **** enumerator_history *new_enum_history; gcc_assert (sym != NULL && init != NULL); ! new_enum_history = gfc_getmem (sizeof (enumerator_history)); new_enum_history->sym = sym; new_enum_history->initializer = init; --- 1150,1156 ---- enumerator_history *new_enum_history; gcc_assert (sym != NULL && init != NULL); ! new_enum_history = XCNEW (enumerator_history); new_enum_history->sym = sym; new_enum_history->initializer = init; *************** gfc_free_enum_history (void) *** 1181,1187 **** /* Function called by variable_decl() that adds an initialization expression to a symbol. */ ! static try add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) { symbol_attribute attr; --- 1195,1201 ---- /* Function called by variable_decl() that adds an initialization expression to a symbol. */ ! static gfc_try add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) { symbol_attribute attr; *************** add_init_expr_to_sym (const char *name, *** 1268,1274 **** gfc_constructor * p; if (init->expr_type == EXPR_CONSTANT) ! gfc_set_constant_character_len (len, init, false); else if (init->expr_type == EXPR_ARRAY) { /* Build a new charlen to prevent simplification from --- 1282,1288 ---- gfc_constructor * p; if (init->expr_type == EXPR_CONSTANT) ! gfc_set_constant_character_len (len, init, -1); else if (init->expr_type == EXPR_ARRAY) { /* Build a new charlen to prevent simplification from *************** add_init_expr_to_sym (const char *name, *** 1279,1285 **** init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length); for (p = init->value.constructor; p; p = p->next) ! gfc_set_constant_character_len (len, p->expr, false); } } } --- 1293,1299 ---- init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length); for (p = init->value.constructor; p; p = p->next) ! gfc_set_constant_character_len (len, p->expr, -1); } } } *************** add_init_expr_to_sym (const char *name, *** 1358,1364 **** /* Function called by variable_decl() that adds a name to a structure being built. */ ! static try build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, gfc_array_spec **as) { --- 1372,1378 ---- /* Function called by variable_decl() that adds a name to a structure being built. */ ! static gfc_try build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, gfc_array_spec **as) { *************** build_struct (const char *name, gfc_char *** 1389,1426 **** c->ts = current_ts; c->ts.cl = cl; ! gfc_set_component_attr (c, ¤t_attr); c->initializer = *init; *init = NULL; c->as = *as; if (c->as != NULL) ! c->dimension = 1; *as = NULL; /* Should this ever get more complicated, combine with similar section in add_init_expr_to_sym into a separate function. */ ! if (c->ts.type == BT_CHARACTER && !c->pointer && c->initializer) { ! int len = mpz_get_si (c->ts.cl->length->value.integer); if (c->initializer->expr_type == EXPR_CONSTANT) ! gfc_set_constant_character_len (len, c->initializer, false); else if (mpz_cmp (c->ts.cl->length->value.integer, c->initializer->ts.cl->length->value.integer)) { gfc_constructor *ctor = c->initializer->value.constructor; ! for (;ctor ; ctor = ctor->next) ! if (ctor->expr->expr_type == EXPR_CONSTANT) ! gfc_set_constant_character_len (len, ctor->expr, true); } } /* Check array components. */ ! if (!c->dimension) { ! if (c->allocatable) { gfc_error ("Allocatable component at %C must be an array"); return FAILURE; --- 1403,1469 ---- c->ts = current_ts; c->ts.cl = cl; ! c->attr = current_attr; c->initializer = *init; *init = NULL; c->as = *as; if (c->as != NULL) ! c->attr.dimension = 1; *as = NULL; /* Should this ever get more complicated, combine with similar section in add_init_expr_to_sym into a separate function. */ ! if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer && c->ts.cl ! && c->ts.cl->length && c->ts.cl->length->expr_type == EXPR_CONSTANT) { ! int len; ! ! gcc_assert (c->ts.cl && c->ts.cl->length); ! gcc_assert (c->ts.cl->length->expr_type == EXPR_CONSTANT); ! gcc_assert (c->ts.cl->length->ts.type == BT_INTEGER); ! ! len = mpz_get_si (c->ts.cl->length->value.integer); if (c->initializer->expr_type == EXPR_CONSTANT) ! gfc_set_constant_character_len (len, c->initializer, -1); else if (mpz_cmp (c->ts.cl->length->value.integer, c->initializer->ts.cl->length->value.integer)) { + bool has_ts; gfc_constructor *ctor = c->initializer->value.constructor; ! ! bool first = true; ! int first_len; ! ! has_ts = (c->initializer->ts.cl ! && c->initializer->ts.cl->length_from_typespec); ! ! for (; ctor; ctor = ctor->next) ! { ! /* Remember the length of the first element for checking that ! all elements *in the constructor* have the same length. This ! need not be the length of the LHS! */ ! if (first) ! { ! gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT); ! gcc_assert (ctor->expr->ts.type == BT_CHARACTER); ! first_len = ctor->expr->value.character.length; ! first = false; ! } ! ! if (ctor->expr->expr_type == EXPR_CONSTANT) ! gfc_set_constant_character_len (len, ctor->expr, ! has_ts ? -1 : first_len); ! } } } /* Check array components. */ ! if (!c->attr.dimension) { ! if (c->attr.allocatable) { gfc_error ("Allocatable component at %C must be an array"); return FAILURE; *************** build_struct (const char *name, gfc_char *** 1429,1435 **** return SUCCESS; } ! if (c->pointer) { if (c->as->type != AS_DEFERRED) { --- 1472,1478 ---- return SUCCESS; } ! if (c->attr.pointer) { if (c->as->type != AS_DEFERRED) { *************** build_struct (const char *name, gfc_char *** 1438,1444 **** return FAILURE; } } ! else if (c->allocatable) { if (c->as->type != AS_DEFERRED) { --- 1481,1487 ---- return FAILURE; } } ! else if (c->attr.allocatable) { if (c->as->type != AS_DEFERRED) { *************** variable_decl (int elem) *** 1515,1521 **** gfc_charlen *cl; locus var_locus; match m; ! try t; gfc_symbol *sym; locus old_locus; --- 1558,1564 ---- gfc_charlen *cl; locus var_locus; match m; ! gfc_try t; gfc_symbol *sym; locus old_locus; *************** kind_expr: *** 1939,1946 **** return MATCH_ERROR; } gfc_gobble_whitespace (); ! if ((c = gfc_next_char ()) != ')' && (ts->type != BT_CHARACTER || c != ',')) { if (ts->type == BT_CHARACTER) gfc_error ("Missing right parenthesis or comma at %C"); --- 1982,2001 ---- return MATCH_ERROR; } + /* Warn if, e.g., c_int is used for a REAL variable, but not + if, e.g., c_double is used for COMPLEX as the standard + explicitly says that the kind type parameter for complex and real + variable is the same, i.e. c_float == c_float_complex. */ + if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type + && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX) + || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL))) + gfc_error_now ("C kind type parameter is for type %s but type at %L " + "is %s", gfc_basic_typename (ts->f90_type), &where, + gfc_basic_typename (ts->type)); + gfc_gobble_whitespace (); ! if ((c = gfc_next_ascii_char ()) != ')' ! && (ts->type != BT_CHARACTER || c != ',')) { if (ts->type == BT_CHARACTER) gfc_error ("Missing right parenthesis or comma at %C"); *************** gfc_match_type_spec (gfc_typespec *ts, i *** 2213,2219 **** char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym; match m; ! int c; bool seen_deferred_kind; /* A belt and braces check that the typespec is correctly being treated --- 2268,2274 ---- char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym; match m; ! char c; bool seen_deferred_kind; /* A belt and braces check that the typespec is correctly being treated *************** get_kind: *** 2360,2366 **** if (gfc_current_form == FORM_FREE) { ! c = gfc_peek_char(); if (!gfc_is_whitespace(c) && c != '*' && c != '(' && c != ':' && c != ',') return MATCH_NO; --- 2415,2421 ---- if (gfc_current_form == FORM_FREE) { ! c = gfc_peek_ascii_char(); if (!gfc_is_whitespace(c) && c != '*' && c != '(' && c != ':' && c != ',') return MATCH_NO; *************** gfc_match_implicit_none (void) *** 2400,2412 **** static match match_implicit_range (void) { ! int c, c1, c2, inner; locus cur_loc; cur_loc = gfc_current_locus; gfc_gobble_whitespace (); ! c = gfc_next_char (); if (c != '(') { gfc_error ("Missing character range in IMPLICIT at %C"); --- 2455,2468 ---- static match match_implicit_range (void) { ! char c, c1, c2; ! int inner; locus cur_loc; cur_loc = gfc_current_locus; gfc_gobble_whitespace (); ! c = gfc_next_ascii_char (); if (c != '(') { gfc_error ("Missing character range in IMPLICIT at %C"); *************** match_implicit_range (void) *** 2417,2428 **** while (inner) { gfc_gobble_whitespace (); ! c1 = gfc_next_char (); if (!ISALPHA (c1)) goto bad; gfc_gobble_whitespace (); ! c = gfc_next_char (); switch (c) { --- 2473,2484 ---- while (inner) { gfc_gobble_whitespace (); ! c1 = gfc_next_ascii_char (); if (!ISALPHA (c1)) goto bad; gfc_gobble_whitespace (); ! c = gfc_next_ascii_char (); switch (c) { *************** match_implicit_range (void) *** 2435,2446 **** case '-': gfc_gobble_whitespace (); ! c2 = gfc_next_char (); if (!ISALPHA (c2)) goto bad; gfc_gobble_whitespace (); ! c = gfc_next_char (); if ((c != ',') && (c != ')')) goto bad; --- 2491,2502 ---- case '-': gfc_gobble_whitespace (); ! c2 = gfc_next_ascii_char (); if (!ISALPHA (c2)) goto bad; gfc_gobble_whitespace (); ! c = gfc_next_ascii_char (); if ((c != ',') && (c != ')')) goto bad; *************** gfc_match_implicit (void) *** 2503,2511 **** { gfc_typespec ts; locus cur_loc; ! int c; match m; /* We don't allow empty implicit statements. */ if (gfc_match_eos () == MATCH_YES) { --- 2559,2569 ---- { gfc_typespec ts; locus cur_loc; ! char c; match m; + gfc_clear_ts (&ts); + /* We don't allow empty implicit statements. */ if (gfc_match_eos () == MATCH_YES) { *************** gfc_match_implicit (void) *** 2532,2538 **** { /* We may have (). */ gfc_gobble_whitespace (); ! c = gfc_next_char (); if ((c == '\n') || (c == ',')) { /* Check for CHARACTER with no length parameter. */ --- 2590,2596 ---- { /* We may have (). */ gfc_gobble_whitespace (); ! c = gfc_next_ascii_char (); if ((c == '\n') || (c == ',')) { /* Check for CHARACTER with no length parameter. */ *************** gfc_match_implicit (void) *** 2582,2588 **** goto syntax; gfc_gobble_whitespace (); ! c = gfc_next_char (); if ((c != '\n') && (c != ',')) goto syntax; --- 2640,2646 ---- goto syntax; gfc_gobble_whitespace (); ! c = gfc_next_ascii_char (); if ((c != '\n') && (c != ',')) goto syntax; *************** match_string_p (const char *target) *** 2711,2717 **** const char *p; for (p = target; *p; p++) ! if (gfc_next_char () != *p) return false; return true; } --- 2769,2775 ---- const char *p; for (p = target; *p; p++) ! if ((char) gfc_next_ascii_char () != *p) return false; return true; } *************** match_attr_spec (void) *** 2749,2755 **** decl_types d; const char *attr; match m; ! try t; gfc_clear_attr (¤t_attr); start = gfc_current_locus; --- 2807,2813 ---- decl_types d; const char *attr; match m; ! gfc_try t; gfc_clear_attr (¤t_attr); start = gfc_current_locus; *************** match_attr_spec (void) *** 2763,2784 **** for (;;) { ! int ch; d = DECL_NONE; gfc_gobble_whitespace (); ! ch = gfc_next_char (); if (ch == ':') { /* This is the successful exit condition for the loop. */ ! if (gfc_next_char () == ':') break; } else if (ch == ',') { gfc_gobble_whitespace (); ! switch (gfc_peek_char ()) { case 'a': if (match_string_p ("allocatable")) --- 2821,2842 ---- for (;;) { ! char ch; d = DECL_NONE; gfc_gobble_whitespace (); ! ch = gfc_next_ascii_char (); if (ch == ':') { /* This is the successful exit condition for the loop. */ ! if (gfc_next_ascii_char () == ':') break; } else if (ch == ',') { gfc_gobble_whitespace (); ! switch (gfc_peek_ascii_char ()) { case 'a': if (match_string_p ("allocatable")) *************** match_attr_spec (void) *** 2807,2813 **** case 'i': if (match_string_p ("int")) { ! ch = gfc_next_char (); if (ch == 'e') { if (match_string_p ("nt")) --- 2865,2871 ---- case 'i': if (match_string_p ("int")) { ! ch = gfc_next_ascii_char (); if (ch == 'e') { if (match_string_p ("nt")) *************** match_attr_spec (void) *** 2839,2846 **** break; case 'p': ! gfc_next_char (); ! switch (gfc_next_char ()) { case 'a': if (match_string_p ("rameter")) --- 2897,2904 ---- break; case 'p': ! gfc_next_ascii_char (); ! switch (gfc_next_ascii_char ()) { case 'a': if (match_string_p ("rameter")) *************** match_attr_spec (void) *** 2859,2865 **** break; case 'r': ! ch = gfc_next_char (); if (ch == 'i') { if (match_string_p ("vate")) --- 2917,2923 ---- break; case 'r': ! ch = gfc_next_ascii_char (); if (ch == 'i') { if (match_string_p ("vate")) *************** match_attr_spec (void) *** 2899,2906 **** break; case 'v': ! gfc_next_char (); ! ch = gfc_next_char (); if (ch == 'a') { if (match_string_p ("lue")) --- 2957,2964 ---- break; case 'v': ! gfc_next_ascii_char (); ! ch = gfc_next_ascii_char (); if (ch == 'a') { if (match_string_p ("lue")) *************** match_attr_spec (void) *** 2929,2934 **** --- 2987,2999 ---- goto cleanup; } + /* Check to make sure any parens are paired up correctly. */ + if (gfc_match_parens () == MATCH_ERROR) + { + m = MATCH_ERROR; + goto cleanup; + } + seen[d]++; seen_at[d] = gfc_current_locus; *************** cleanup: *** 3204,3210 **** (J3/04-007, section 15.4.1). If a binding label was given and there is more than one argument (num_idents), it is an error. */ ! try set_binding_label (char *dest_label, const char *sym_name, int num_idents) { if (num_idents > 1 && has_name_equals) --- 3269,3275 ---- (J3/04-007, section 15.4.1). If a binding label was given and there is more than one argument (num_idents), it is an error. */ ! gfc_try set_binding_label (char *dest_label, const char *sym_name, int num_idents) { if (num_idents > 1 && has_name_equals) *************** set_com_block_bind_c (gfc_common_head *c *** 3244,3273 **** /* Verify that the given gfc_typespec is for a C interoperable type. */ ! try ! verify_c_interop (gfc_typespec *ts, const char *name, locus *where) { - try t; - - /* Make sure the kind used is appropriate for the type. - The f90_type is unknown if an integer constant was - used (e.g., real(4), bind(c) :: myFloat). */ - if (ts->f90_type != BT_UNKNOWN) - { - t = gfc_validate_c_kind (ts); - if (t != SUCCESS) - { - /* Print an error, but continue parsing line. */ - gfc_error_now ("C kind parameter is for type %s but " - "symbol '%s' at %L is of type %s", - gfc_basic_typename (ts->f90_type), - name, where, - gfc_basic_typename (ts->type)); - } - } - - /* Make sure the kind is C interoperable. This does not care about the - possible error above. */ if (ts->type == BT_DERIVED && ts->derived != NULL) return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE); else if (ts->is_c_interop != 1) --- 3309,3317 ---- /* Verify that the given gfc_typespec is for a C interoperable type. */ ! gfc_try ! verify_c_interop (gfc_typespec *ts) { if (ts->type == BT_DERIVED && ts->derived != NULL) return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE); else if (ts->is_c_interop != 1) *************** verify_c_interop (gfc_typespec *ts, cons *** 3282,3292 **** interoperable type. Errors will be reported here, if encountered. */ ! try verify_com_block_vars_c_interop (gfc_common_head *com_block) { gfc_symbol *curr_sym = NULL; ! try retval = SUCCESS; curr_sym = com_block->head; --- 3326,3336 ---- interoperable type. Errors will be reported here, if encountered. */ ! gfc_try verify_com_block_vars_c_interop (gfc_common_head *com_block) { gfc_symbol *curr_sym = NULL; ! gfc_try retval = SUCCESS; curr_sym = com_block->head; *************** verify_com_block_vars_c_interop (gfc_com *** 3310,3320 **** /* Verify that a given BIND(C) symbol is C interoperable. If it is not, an appropriate error message is reported. */ ! try verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, int is_in_common, gfc_common_head *com_block) { ! try retval = SUCCESS; if (tmp_sym->attr.function && tmp_sym->result != NULL) { --- 3354,3368 ---- /* Verify that a given BIND(C) symbol is C interoperable. If it is not, an appropriate error message is reported. */ ! gfc_try verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, int is_in_common, gfc_common_head *com_block) { ! bool bind_c_function = false; ! gfc_try retval = SUCCESS; ! ! if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c) ! bind_c_function = true; if (tmp_sym->attr.function && tmp_sym->result != NULL) { *************** verify_bind_c_sym (gfc_symbol *tmp_sym, *** 3331,3345 **** tmp_sym->attr.is_c_interop = 1; } } ! /* Here, we know we have the bind(c) attribute, so if we have enough type info, then verify that it's a C interop kind. The info could be in the symbol already, or possibly still in the given ts (current_ts), so look in both. */ if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) { ! if (verify_c_interop (&(tmp_sym->ts), tmp_sym->name, ! &(tmp_sym->declared_at)) != SUCCESS) { /* See if we're dealing with a sym in a common block or not. */ if (is_in_common == 1) --- 3379,3392 ---- tmp_sym->attr.is_c_interop = 1; } } ! /* Here, we know we have the bind(c) attribute, so if we have enough type info, then verify that it's a C interop kind. The info could be in the symbol already, or possibly still in the given ts (current_ts), so look in both. */ if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) { ! if (verify_c_interop (&(tmp_sym->ts)) != SUCCESS) { /* See if we're dealing with a sym in a common block or not. */ if (is_in_common == 1) *************** verify_bind_c_sym (gfc_symbol *tmp_sym, *** 3397,3418 **** retval = FAILURE; } ! /* If it is a BIND(C) function, make sure the return value is a ! scalar value. The previous tests in this function made sure ! the type is interoperable. */ ! if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL) ! gfc_error ("Return type of BIND(C) function '%s' at %L cannot " ! "be an array", tmp_sym->name, &(tmp_sym->declared_at)); ! /* BIND(C) functions can not return a character string. */ ! if (tmp_sym->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER) ! if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL ! || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT ! || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0) ! gfc_error ("Return type of BIND(C) function '%s' at %L cannot " "be a character string", tmp_sym->name, &(tmp_sym->declared_at)); - } } /* See if the symbol has been marked as private. If it has, make sure --- 3444,3466 ---- retval = FAILURE; } ! } ! /* If it is a BIND(C) function, make sure the return value is a ! scalar value. The previous tests in this function made sure ! the type is interoperable. */ ! if (bind_c_function && tmp_sym->as != NULL) ! gfc_error ("Return type of BIND(C) function '%s' at %L cannot " ! "be an array", tmp_sym->name, &(tmp_sym->declared_at)); ! ! /* BIND(C) functions can not return a character string. */ ! if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER) ! if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL ! || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT ! || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0) ! gfc_error ("Return type of BIND(C) function '%s' at %L cannot " "be a character string", tmp_sym->name, &(tmp_sym->declared_at)); } /* See if the symbol has been marked as private. If it has, make sure *************** verify_bind_c_sym (gfc_symbol *tmp_sym, *** 3434,3443 **** the type is C interoperable. Errors are reported by the functions used to set/test these fields. */ ! try set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) { ! try retval = SUCCESS; /* TODO: Do we need to make sure the vars aren't marked private? */ --- 3482,3491 ---- the type is C interoperable. Errors are reported by the functions used to set/test these fields. */ ! gfc_try set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) { ! gfc_try retval = SUCCESS; /* TODO: Do we need to make sure the vars aren't marked private? */ *************** set_verify_bind_c_sym (gfc_symbol *tmp_s *** 3455,3464 **** /* Set the fields marking the given common block as BIND(C), including a binding label, and report any errors encountered. */ ! try set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) { ! try retval = SUCCESS; /* destLabel, common name, typespec (which may have binding label). */ if (set_binding_label (com_block->binding_label, com_block->name, num_idents) --- 3503,3512 ---- /* Set the fields marking the given common block as BIND(C), including a binding label, and report any errors encountered. */ ! gfc_try set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) { ! gfc_try retval = SUCCESS; /* destLabel, common name, typespec (which may have binding label). */ if (set_binding_label (com_block->binding_label, com_block->name, num_idents) *************** set_verify_bind_c_com_block (gfc_common_ *** 3475,3481 **** /* Retrieve the list of one or more identifiers that the given bind(c) attribute applies to. */ ! try get_bind_c_idents (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; --- 3523,3529 ---- /* Retrieve the list of one or more identifiers that the given bind(c) attribute applies to. */ ! gfc_try get_bind_c_idents (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; *************** gfc_match_prefix (gfc_typespec *ts) *** 3707,3712 **** --- 3755,3763 ---- gfc_clear_attr (¤t_attr); seen_type = 0; + gcc_assert (!gfc_matching_prefix); + gfc_matching_prefix = true; + loop: if (!seen_type && ts != NULL && gfc_match_type_spec (ts, 0) == MATCH_YES *************** loop: *** 3720,3726 **** if (gfc_match ("elemental% ") == MATCH_YES) { if (gfc_add_elemental (¤t_attr, NULL) == FAILURE) ! return MATCH_ERROR; goto loop; } --- 3771,3777 ---- if (gfc_match ("elemental% ") == MATCH_YES) { if (gfc_add_elemental (¤t_attr, NULL) == FAILURE) ! goto error; goto loop; } *************** loop: *** 3728,3734 **** if (gfc_match ("pure% ") == MATCH_YES) { if (gfc_add_pure (¤t_attr, NULL) == FAILURE) ! return MATCH_ERROR; goto loop; } --- 3779,3785 ---- if (gfc_match ("pure% ") == MATCH_YES) { if (gfc_add_pure (¤t_attr, NULL) == FAILURE) ! goto error; goto loop; } *************** loop: *** 3736,3754 **** if (gfc_match ("recursive% ") == MATCH_YES) { if (gfc_add_recursive (¤t_attr, NULL) == FAILURE) ! return MATCH_ERROR; goto loop; } /* At this point, the next item is not a prefix. */ return MATCH_YES; } /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */ ! static try copy_prefix (symbol_attribute *dest, locus *where) { if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE) --- 3787,3812 ---- if (gfc_match ("recursive% ") == MATCH_YES) { if (gfc_add_recursive (¤t_attr, NULL) == FAILURE) ! goto error; goto loop; } /* At this point, the next item is not a prefix. */ + gcc_assert (gfc_matching_prefix); + gfc_matching_prefix = false; return MATCH_YES; + + error: + gcc_assert (gfc_matching_prefix); + gfc_matching_prefix = false; + return MATCH_ERROR; } /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */ ! static gfc_try copy_prefix (symbol_attribute *dest, locus *where) { if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE) *************** match_result (gfc_symbol *function, gfc_ *** 3916,3923 **** if (gfc_get_symbol (name, NULL, &r)) return MATCH_ERROR; ! if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE ! || gfc_add_result (&r->attr, r->name, NULL) == FAILURE) return MATCH_ERROR; *result = r; --- 3974,3980 ---- if (gfc_get_symbol (name, NULL, &r)) return MATCH_ERROR; ! if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE) return MATCH_ERROR; *result = r; *************** gfc_match_suffix (gfc_symbol *sym, gfc_s *** 3936,3942 **** match is_bind_c; /* Found bind(c). */ match is_result; /* Found result clause. */ match found_match; /* Status of whether we've found a good match. */ ! int peek_char; /* Character we're going to peek at. */ bool allow_binding_name; /* Initialize to having found nothing. */ --- 3993,3999 ---- match is_bind_c; /* Found bind(c). */ match is_result; /* Found result clause. */ match found_match; /* Status of whether we've found a good match. */ ! char peek_char; /* Character we're going to peek at. */ bool allow_binding_name; /* Initialize to having found nothing. */ *************** gfc_match_suffix (gfc_symbol *sym, gfc_s *** 3946,3952 **** /* Get the next char to narrow between result and bind(c). */ gfc_gobble_whitespace (); ! peek_char = gfc_peek_char (); /* C binding names are not allowed for internal procedures. */ if (gfc_current_state () == COMP_CONTAINS --- 4003,4009 ---- /* Get the next char to narrow between result and bind(c). */ gfc_gobble_whitespace (); ! peek_char = gfc_peek_ascii_char (); /* C binding names are not allowed for internal procedures. */ if (gfc_current_state () == COMP_CONTAINS *************** gfc_match_suffix (gfc_symbol *sym, gfc_s *** 3997,4005 **** /* Fortran 2008 draft allows BIND(C) for internal procedures. */ if (gfc_current_state () == COMP_CONTAINS && sym->ns->proc_name->attr.flavor != FL_MODULE ! && gfc_notify_std (GFC_STD_GNU, "Extension: BIND(C) attribute at %L " ! "may not be specified for an internal procedure", ! &gfc_current_locus) == FAILURE) return MATCH_ERROR; --- 4054,4062 ---- /* Fortran 2008 draft allows BIND(C) for internal procedures. */ if (gfc_current_state () == COMP_CONTAINS && sym->ns->proc_name->attr.flavor != FL_MODULE ! && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute " ! "at %L may not be specified for an internal " ! "procedure", &gfc_current_locus) == FAILURE) return MATCH_ERROR; *************** match_procedure_decl (void) *** 4021,4026 **** --- 4078,4084 ---- locus old_loc, entry_loc; gfc_symbol *sym, *proc_if = NULL; int num; + gfc_expr *initializer = NULL; old_loc = entry_loc = gfc_current_locus; *************** match_procedure_decl (void) *** 4035,4041 **** /* Get the type spec. for the procedure interface. */ old_loc = gfc_current_locus; m = gfc_match_type_spec (¤t_ts, 0); ! if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')')) goto got_ts; if (m == MATCH_ERROR) --- 4093,4100 ---- /* Get the type spec. for the procedure interface. */ old_loc = gfc_current_locus; m = gfc_match_type_spec (¤t_ts, 0); ! gfc_gobble_whitespace (); ! if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')')) goto got_ts; if (m == MATCH_ERROR) *************** match_procedure_decl (void) *** 4055,4065 **** /* Various interface checks. */ if (proc_if) { /* Resolve interface if possible. That way, attr.procedure is only set if it is declared by a later procedure-declaration-stmt, which is invalid per C1212. */ ! while (proc_if->interface) ! proc_if = proc_if->interface; if (proc_if->generic) { --- 4114,4125 ---- /* Various interface checks. */ if (proc_if) { + proc_if->refs++; /* Resolve interface if possible. That way, attr.procedure is only set if it is declared by a later procedure-declaration-stmt, which is invalid per C1212. */ ! while (proc_if->ts.interface) ! proc_if = proc_if->ts.interface; if (proc_if->generic) { *************** match_procedure_decl (void) *** 4073,4080 **** return MATCH_ERROR; } /* Handle intrinsic procedures. */ ! if (gfc_intrinsic_name (proc_if->name, 0) ! || gfc_intrinsic_name (proc_if->name, 1)) proc_if->attr.intrinsic = 1; if (proc_if->attr.intrinsic && !gfc_intrinsic_actual_ok (proc_if->name, 0)) --- 4133,4142 ---- return MATCH_ERROR; } /* Handle intrinsic procedures. */ ! if (!(proc_if->attr.external || proc_if->attr.use_assoc ! || proc_if->attr.if_source == IFSRC_IFBODY) ! && (gfc_is_intrinsic (proc_if, 0, gfc_current_locus) ! || gfc_is_intrinsic (proc_if, 1, gfc_current_locus))) proc_if->attr.intrinsic = 1; if (proc_if->attr.intrinsic && !gfc_intrinsic_actual_ok (proc_if->name, 0)) *************** got_ts: *** 4137,4143 **** return MATCH_ERROR; } ! if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE) return MATCH_ERROR; if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; --- 4199,4205 ---- return MATCH_ERROR; } ! if (gfc_add_external (&sym->attr, NULL) == FAILURE) return MATCH_ERROR; if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; *************** got_ts: *** 4145,4162 **** /* Set interface. */ if (proc_if != NULL) { ! sym->interface = proc_if; sym->attr.untyped = 1; } else if (current_ts.type != BT_UNKNOWN) { ! sym->interface = gfc_new_symbol ("", gfc_current_ns); ! sym->interface->ts = current_ts; ! sym->interface->attr.function = 1; ! sym->ts = sym->interface->ts; ! sym->attr.function = sym->interface->attr.function; } if (gfc_match_eos () == MATCH_YES) return MATCH_YES; if (gfc_match_char (',') != MATCH_YES) --- 4207,4258 ---- /* Set interface. */ if (proc_if != NULL) { ! sym->ts.interface = proc_if; sym->attr.untyped = 1; } else if (current_ts.type != BT_UNKNOWN) { ! sym->ts = current_ts; ! sym->ts.interface = gfc_new_symbol ("", gfc_current_ns); ! sym->ts.interface->ts = current_ts; ! sym->ts.interface->attr.function = 1; ! sym->attr.function = sym->ts.interface->attr.function; } + if (gfc_match (" =>") == MATCH_YES) + { + if (!current_attr.pointer) + { + gfc_error ("Initialization at %C isn't for a pointer variable"); + m = MATCH_ERROR; + goto cleanup; + } + + m = gfc_match_null (&initializer); + if (m == MATCH_NO) + { + gfc_error ("Pointer initialization requires a NULL() at %C"); + m = MATCH_ERROR; + } + + if (gfc_pure (NULL)) + { + gfc_error ("Initialization of pointer at %C is not allowed in " + "a PURE procedure"); + m = MATCH_ERROR; + } + + if (m != MATCH_YES) + goto cleanup; + + if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus) + != SUCCESS) + goto cleanup; + + } + + gfc_set_sym_referenced (sym); + if (gfc_match_eos () == MATCH_YES) return MATCH_YES; if (gfc_match_char (',') != MATCH_YES) *************** got_ts: *** 4166,4171 **** --- 4262,4272 ---- syntax: gfc_error ("Syntax error in PROCEDURE statement at %C"); return MATCH_ERROR; + + cleanup: + /* Free stuff up and return. */ + gfc_free_expr (initializer); + return m; } *************** syntax: *** 4214,4219 **** --- 4315,4322 ---- /* General matcher for PROCEDURE declarations. */ + static match match_procedure_in_type (void); + match gfc_match_procedure (void) { *************** gfc_match_procedure (void) *** 4232,4240 **** m = match_procedure_in_interface (); break; case COMP_DERIVED: ! gfc_error ("Fortran 2003: Procedure components at %C are " ! "not yet implemented in gfortran"); return MATCH_ERROR; default: return MATCH_NO; } --- 4335,4346 ---- m = match_procedure_in_interface (); break; case COMP_DERIVED: ! gfc_error ("Fortran 2003: Procedure components at %C are not yet" ! " implemented in gfortran"); return MATCH_ERROR; + case COMP_DERIVED_CONTAINS: + m = match_procedure_in_type (); + break; default: return MATCH_NO; } *************** gfc_match_procedure (void) *** 4250,4255 **** --- 4356,4377 ---- } + /* Warn if a matched procedure has the same name as an intrinsic; this is + simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current + parser-state-stack to find out whether we're in a module. */ + + static void + warn_intrinsic_shadow (const gfc_symbol* sym, bool func) + { + bool in_module; + + in_module = (gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_MODULE); + + gfc_warn_intrinsic_shadow (sym, in_module, func); + } + + /* Match a function declaration. */ match *************** gfc_match_function_decl (void) *** 4374,4379 **** --- 4496,4504 ---- sym->result = result; } + /* Warn if this procedure has the same name as an intrinsic. */ + warn_intrinsic_shadow (sym, true); + return MATCH_YES; } *************** gfc_match_entry (void) *** 4527,4533 **** /* Check what next non-whitespace character is so we can tell if there is the required parens if we have a BIND(C). */ gfc_gobble_whitespace (); ! peek_char = gfc_peek_char (); if (state == COMP_SUBROUTINE) { --- 4652,4658 ---- /* Check what next non-whitespace character is so we can tell if there is the required parens if we have a BIND(C). */ gfc_gobble_whitespace (); ! peek_char = gfc_peek_ascii_char (); if (state == COMP_SUBROUTINE) { *************** gfc_match_subroutine (void) *** 4683,4689 **** /* Check what next non-whitespace character is so we can tell if there is the required parens if we have a BIND(C). */ gfc_gobble_whitespace (); ! peek_char = gfc_peek_char (); if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; --- 4808,4814 ---- /* Check what next non-whitespace character is so we can tell if there is the required parens if we have a BIND(C). */ gfc_gobble_whitespace (); ! peek_char = gfc_peek_ascii_char (); if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; *************** gfc_match_subroutine (void) *** 4730,4738 **** /* The following is allowed in the Fortran 2008 draft. */ if (gfc_current_state () == COMP_CONTAINS && sym->ns->proc_name->attr.flavor != FL_MODULE ! && gfc_notify_std (GFC_STD_GNU, "Extension: BIND(C) attribute at " ! "%L may not be specified for an internal procedure", ! &gfc_current_locus) == FAILURE) return MATCH_ERROR; --- 4855,4863 ---- /* The following is allowed in the Fortran 2008 draft. */ if (gfc_current_state () == COMP_CONTAINS && sym->ns->proc_name->attr.flavor != FL_MODULE ! && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute " ! "at %L may not be specified for an internal " ! "procedure", &gfc_current_locus) == FAILURE) return MATCH_ERROR; *************** gfc_match_subroutine (void) *** 4755,4760 **** --- 4880,4888 ---- if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE) return MATCH_ERROR; + /* Warn if it has the same name as an intrinsic. */ + warn_intrinsic_shadow (sym, false); + return MATCH_YES; } *************** gfc_match_end (gfc_statement *st) *** 4970,4976 **** block_name = gfc_current_block () == NULL ? NULL : gfc_current_block ()->name; ! if (state == COMP_CONTAINS) { state = gfc_state_stack->previous->state; block_name = gfc_state_stack->previous->sym == NULL --- 5098,5104 ---- block_name = gfc_current_block () == NULL ? NULL : gfc_current_block ()->name; ! if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS) { state = gfc_state_stack->previous->state; block_name = gfc_state_stack->previous->sym == NULL *************** gfc_match_end (gfc_statement *st) *** 5017,5022 **** --- 5145,5151 ---- break; case COMP_DERIVED: + case COMP_DERIVED_CONTAINS: *st = ST_END_TYPE; target = " type"; eos_ok = 0; *************** attr_decl1 (void) *** 5203,5209 **** /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */ if (current_attr.dimension == 0 ! && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE) { m = MATCH_ERROR; goto cleanup; --- 5332,5338 ---- /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */ if (current_attr.dimension == 0 ! && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE) { m = MATCH_ERROR; goto cleanup; *************** match *** 5483,5489 **** gfc_match_pointer (void) { gfc_gobble_whitespace (); ! if (gfc_peek_char () == '(') { if (!gfc_option.flag_cray_pointer) { --- 5612,5618 ---- gfc_match_pointer (void) { gfc_gobble_whitespace (); ! if (gfc_peek_ascii_char () == '(') { if (!gfc_option.flag_cray_pointer) { *************** access_attr_decl (gfc_statement st) *** 5543,5549 **** interface_type type; gfc_user_op *uop; gfc_symbol *sym; ! gfc_intrinsic_op operator; match m; if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) --- 5672,5678 ---- interface_type type; gfc_user_op *uop; gfc_symbol *sym; ! gfc_intrinsic_op op; match m; if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) *************** access_attr_decl (gfc_statement st) *** 5551,5557 **** for (;;) { ! m = gfc_match_generic_spec (&type, name, &operator); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) --- 5680,5686 ---- for (;;) { ! m = gfc_match_generic_spec (&type, name, &op); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) *************** access_attr_decl (gfc_statement st) *** 5575,5589 **** break; case INTERFACE_INTRINSIC_OP: ! if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN) { ! gfc_current_ns->operator_access[operator] = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; } else { gfc_error ("Access specification of the %s operator at %C has " ! "already been specified", gfc_op2string (operator)); goto done; } --- 5704,5718 ---- break; case INTERFACE_INTRINSIC_OP: ! if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN) { ! gfc_current_ns->operator_access[op] = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; } else { gfc_error ("Access specification of the %s operator at %C has " ! "already been specified", gfc_op2string (op)); goto done; } *************** syntax: *** 5683,5689 **** /* The PRIVATE statement is a bit weird in that it can be an attribute ! declaration, but also works as a standlone statement inside of a type declaration or a module. */ match --- 5812,5818 ---- /* The PRIVATE statement is a bit weird in that it can be an attribute ! declaration, but also works as a standalone statement inside of a type declaration or a module. */ match *************** gfc_match_private (gfc_statement *st) *** 5694,5702 **** return MATCH_NO; if (gfc_current_state () != COMP_MODULE ! && (gfc_current_state () != COMP_DERIVED ! || !gfc_state_stack->previous ! || gfc_state_stack->previous->state != COMP_MODULE)) { gfc_error ("PRIVATE statement at %C is only allowed in the " "specification part of a module"); --- 5823,5834 ---- return MATCH_NO; if (gfc_current_state () != COMP_MODULE ! && !(gfc_current_state () == COMP_DERIVED ! && gfc_state_stack->previous ! && gfc_state_stack->previous->state == COMP_MODULE) ! && !(gfc_current_state () == COMP_DERIVED_CONTAINS ! && gfc_state_stack->previous && gfc_state_stack->previous->previous ! && gfc_state_stack->previous->previous->state == COMP_MODULE)) { gfc_error ("PRIVATE statement at %C is only allowed in the " "specification part of a module"); *************** do_parm (void) *** 5805,5814 **** && sym->ts.cl->length != NULL && sym->ts.cl->length->expr_type == EXPR_CONSTANT && init->expr_type == EXPR_CONSTANT ! && init->ts.type == BT_CHARACTER ! && init->ts.kind == 1) gfc_set_constant_character_len ( ! mpz_get_si (sym->ts.cl->length->value.integer), init, false); sym->value = init; return MATCH_YES; --- 5937,5963 ---- && sym->ts.cl->length != NULL && sym->ts.cl->length->expr_type == EXPR_CONSTANT && init->expr_type == EXPR_CONSTANT ! && init->ts.type == BT_CHARACTER) gfc_set_constant_character_len ( ! mpz_get_si (sym->ts.cl->length->value.integer), init, -1); ! else if (sym->ts.type == BT_CHARACTER && sym->ts.cl != NULL ! && sym->ts.cl->length == NULL) ! { ! int clen; ! if (init->expr_type == EXPR_CONSTANT) ! { ! clen = init->value.character.length; ! sym->ts.cl->length = gfc_int_expr (clen); ! } ! else if (init->expr_type == EXPR_ARRAY) ! { ! gfc_expr *p = init->value.constructor->expr; ! clen = p->value.character.length; ! sym->ts.cl->length = gfc_int_expr (clen); ! } ! else if (init->ts.cl && init->ts.cl->length) ! sym->ts.cl->length = gfc_copy_expr (sym->value->ts.cl->length); ! } sym->value = init; return MATCH_YES; *************** syntax: *** 6124,6129 **** --- 6273,6321 ---- } + /* Check a derived type that is being extended. */ + static gfc_symbol* + check_extended_derived_type (char *name) + { + gfc_symbol *extended; + + if (gfc_find_symbol (name, gfc_current_ns, 1, &extended)) + { + gfc_error ("Ambiguous symbol in TYPE definition at %C"); + return NULL; + } + + if (!extended) + { + gfc_error ("No such symbol in TYPE definition at %C"); + return NULL; + } + + if (extended->attr.flavor != FL_DERIVED) + { + gfc_error ("'%s' in EXTENDS expression at %C is not a " + "derived type", name); + return NULL; + } + + if (extended->attr.is_bind_c) + { + gfc_error ("'%s' cannot be extended at %C because it " + "is BIND(C)", extended->name); + return NULL; + } + + if (extended->attr.sequence) + { + gfc_error ("'%s' cannot be extended at %C because it " + "is a SEQUENCE type", extended->name); + return NULL; + } + + return extended; + } + + /* Match the optional attribute specifiers for a type declaration. Return MATCH_ERROR if an error is encountered in one of the handled attributes (public, private, bind(c)), MATCH_NO if what's found is *************** syntax: *** 6131,6137 **** checking on attribute conflicts needs to be done. */ match ! gfc_get_type_attr_spec (symbol_attribute *attr) { /* See if the derived type is marked as private. */ if (gfc_match (" , private") == MATCH_YES) --- 6323,6329 ---- checking on attribute conflicts needs to be done. */ match ! gfc_get_type_attr_spec (symbol_attribute *attr, char *name) { /* See if the derived type is marked as private. */ if (gfc_match (" , private") == MATCH_YES) *************** gfc_get_type_attr_spec (symbol_attribute *** 6158,6164 **** if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE) return MATCH_ERROR; } ! else if (gfc_match(" , bind ( c )") == MATCH_YES) { /* If the type is defined to be bind(c) it then needs to make sure that all fields are interoperable. This will --- 6350,6356 ---- if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE) return MATCH_ERROR; } ! else if (gfc_match (" , bind ( c )") == MATCH_YES) { /* If the type is defined to be bind(c) it then needs to make sure that all fields are interoperable. This will *************** gfc_get_type_attr_spec (symbol_attribute *** 6169,6174 **** --- 6361,6380 ---- /* TODO: attr conflicts need to be checked, probably in symbol.c. */ } + else if (gfc_match (" , abstract") == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT type at %C") + == FAILURE) + return MATCH_ERROR; + + if (gfc_add_abstract (attr, &gfc_current_locus) == FAILURE) + return MATCH_ERROR; + } + else if (name && gfc_match(" , extends ( %n )", name) == MATCH_YES) + { + if (gfc_add_extension (attr, &gfc_current_locus) == FAILURE) + return MATCH_ERROR; + } else return MATCH_NO; *************** match *** 6185,6192 **** --- 6391,6400 ---- gfc_match_derived_decl (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; + char parent[GFC_MAX_SYMBOL_LEN + 1]; symbol_attribute attr; gfc_symbol *sym; + gfc_symbol *extended; match m; match is_type_attr_spec = MATCH_NO; bool seen_attr = false; *************** gfc_match_derived_decl (void) *** 6194,6210 **** if (gfc_current_state () == COMP_DERIVED) return MATCH_NO; gfc_clear_attr (&attr); do { ! is_type_attr_spec = gfc_get_type_attr_spec (&attr); if (is_type_attr_spec == MATCH_ERROR) return MATCH_ERROR; if (is_type_attr_spec == MATCH_YES) seen_attr = true; } while (is_type_attr_spec == MATCH_YES); if (gfc_match (" ::") != MATCH_YES && seen_attr) { gfc_error ("Expected :: in TYPE definition at %C"); --- 6402,6430 ---- if (gfc_current_state () == COMP_DERIVED) return MATCH_NO; + name[0] = '\0'; + parent[0] = '\0'; gfc_clear_attr (&attr); + extended = NULL; do { ! is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent); if (is_type_attr_spec == MATCH_ERROR) return MATCH_ERROR; if (is_type_attr_spec == MATCH_YES) seen_attr = true; } while (is_type_attr_spec == MATCH_YES); + /* Deal with derived type extensions. The extension attribute has + been added to 'attr' but now the parent type must be found and + checked. */ + if (parent[0]) + extended = check_extended_derived_type (parent); + + if (parent[0] && !extended) + return MATCH_ERROR; + if (gfc_match (" ::") != MATCH_YES && seen_attr) { gfc_error ("Expected :: in TYPE definition at %C"); *************** gfc_match_derived_decl (void) *** 6237,6243 **** components. The ways this can happen is via a function definition, an INTRINSIC statement or a subtype in another derived type that is a pointer. The first part of the AND clause ! is true if a the symbol is not the return value of a function. */ if (sym->attr.flavor != FL_DERIVED && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; --- 6457,6463 ---- components. The ways this can happen is via a function definition, an INTRINSIC statement or a subtype in another derived type that is a pointer. The first part of the AND clause ! is true if the symbol is not the return value of a function. */ if (sym->attr.flavor != FL_DERIVED && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; *************** gfc_match_derived_decl (void) *** 6257,6262 **** --- 6477,6511 ---- if (attr.is_bind_c != 0) sym->attr.is_bind_c = attr.is_bind_c; + /* Construct the f2k_derived namespace if it is not yet there. */ + if (!sym->f2k_derived) + sym->f2k_derived = gfc_get_namespace (NULL, 0); + + if (extended && !sym->components) + { + gfc_component *p; + gfc_symtree *st; + + /* Add the extended derived type as the first component. */ + gfc_add_component (sym, parent, &p); + sym->attr.extension = attr.extension; + extended->refs++; + gfc_set_sym_referenced (extended); + + p->ts.type = BT_DERIVED; + p->ts.derived = extended; + p->initializer = gfc_default_initializer (&p->ts); + + /* Provide the links between the extended type and its extension. */ + if (!extended->f2k_derived) + extended->f2k_derived = gfc_get_namespace (NULL, 0); + st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name); + st->n.sym = sym; + } + + /* Take over the ABSTRACT attribute. */ + sym->attr.abstract = attr.abstract; + gfc_new_block = sym; return MATCH_YES; *************** gfc_match_derived_decl (void) *** 6270,6276 **** is the case. Since there is no bounds-checking for Cray Pointees, this will be okay. */ ! try gfc_mod_pointee_as (gfc_array_spec *as) { as->cray_pointee = true; /* This will be useful to know later. */ --- 6519,6525 ---- is the case. Since there is no bounds-checking for Cray Pointees, this will be okay. */ ! gfc_try gfc_mod_pointee_as (gfc_array_spec *as) { as->cray_pointee = true; /* This will be useful to know later. */ *************** enumerator_decl (void) *** 6324,6330 **** gfc_symbol *sym; locus var_locus; match m; ! try t; locus old_locus; initializer = NULL; --- 6573,6579 ---- gfc_symbol *sym; locus var_locus; match m; ! gfc_try t; locus old_locus; initializer = NULL; *************** match *** 6407,6413 **** gfc_match_enumerator_def (void) { match m; ! try t; gfc_clear_ts (¤t_ts); --- 6656,6662 ---- gfc_match_enumerator_def (void) { match m; ! gfc_try t; gfc_clear_ts (¤t_ts); *************** cleanup: *** 6467,6469 **** --- 6716,7236 ---- } + + /* Match binding attributes. */ + + static match + match_binding_attributes (gfc_typebound_proc* ba, bool generic) + { + bool found_passing = false; + match m; + + /* Intialize to defaults. Do so even before the MATCH_NO check so that in + this case the defaults are in there. */ + ba->access = ACCESS_UNKNOWN; + ba->pass_arg = NULL; + ba->pass_arg_num = 0; + ba->nopass = 0; + ba->non_overridable = 0; + + /* If we find a comma, we believe there are binding attributes. */ + if (gfc_match_char (',') == MATCH_NO) + { + ba->access = gfc_typebound_default_access; + return MATCH_NO; + } + + do + { + /* Access specifier. */ + + m = gfc_match (" public"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->access != ACCESS_UNKNOWN) + { + gfc_error ("Duplicate access-specifier at %C"); + goto error; + } + + ba->access = ACCESS_PUBLIC; + continue; + } + + m = gfc_match (" private"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->access != ACCESS_UNKNOWN) + { + gfc_error ("Duplicate access-specifier at %C"); + goto error; + } + + ba->access = ACCESS_PRIVATE; + continue; + } + + /* If inside GENERIC, the following is not allowed. */ + if (!generic) + { + + /* NOPASS flag. */ + m = gfc_match (" nopass"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (found_passing) + { + gfc_error ("Binding attributes already specify passing," + " illegal NOPASS at %C"); + goto error; + } + + found_passing = true; + ba->nopass = 1; + continue; + } + + /* NON_OVERRIDABLE flag. */ + m = gfc_match (" non_overridable"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->non_overridable) + { + gfc_error ("Duplicate NON_OVERRIDABLE at %C"); + goto error; + } + + ba->non_overridable = 1; + continue; + } + + /* DEFERRED flag. */ + /* TODO: Handle really once implemented. */ + m = gfc_match (" deferred"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + gfc_error ("DEFERRED not yet implemented at %C"); + goto error; + } + + /* PASS possibly including argument. */ + m = gfc_match (" pass"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + char arg[GFC_MAX_SYMBOL_LEN + 1]; + + if (found_passing) + { + gfc_error ("Binding attributes already specify passing," + " illegal PASS at %C"); + goto error; + } + + m = gfc_match (" ( %n )", arg); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + ba->pass_arg = xstrdup (arg); + gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL)); + + found_passing = true; + ba->nopass = 0; + continue; + } + + } + + /* Nothing matching found. */ + if (generic) + gfc_error ("Expected access-specifier at %C"); + else + gfc_error ("Expected binding attribute at %C"); + goto error; + } + while (gfc_match_char (',') == MATCH_YES); + + if (ba->access == ACCESS_UNKNOWN) + ba->access = gfc_typebound_default_access; + + return MATCH_YES; + + error: + gfc_free (ba->pass_arg); + return MATCH_ERROR; + } + + + /* Match a PROCEDURE specific binding inside a derived type. */ + + static match + match_procedure_in_type (void) + { + char name[GFC_MAX_SYMBOL_LEN + 1]; + char target_buf[GFC_MAX_SYMBOL_LEN + 1]; + char* target; + gfc_typebound_proc* tb; + bool seen_colons; + bool seen_attrs; + match m; + gfc_symtree* stree; + gfc_namespace* ns; + gfc_symbol* block; + + /* Check current state. */ + gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS); + block = gfc_state_stack->previous->sym; + gcc_assert (block); + + /* TODO: Really implement PROCEDURE(interface). */ + if (gfc_match (" (") == MATCH_YES) + { + gfc_error ("PROCEDURE(interface) at %C is not yet implemented"); + return MATCH_ERROR; + } + + /* Construct the data structure. */ + tb = gfc_get_typebound_proc (); + tb->where = gfc_current_locus; + tb->is_generic = 0; + + /* Match binding attributes. */ + m = match_binding_attributes (tb, false); + if (m == MATCH_ERROR) + return m; + seen_attrs = (m == MATCH_YES); + + /* Match the colons. */ + m = gfc_match (" ::"); + if (m == MATCH_ERROR) + return m; + seen_colons = (m == MATCH_YES); + if (seen_attrs && !seen_colons) + { + gfc_error ("Expected '::' after binding-attributes at %C"); + return MATCH_ERROR; + } + + /* Match the binding name. */ + m = gfc_match_name (name); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Expected binding name at %C"); + return MATCH_ERROR; + } + + /* Try to match the '=> target', if it's there. */ + target = NULL; + m = gfc_match (" =>"); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_YES) + { + if (!seen_colons) + { + gfc_error ("'::' needed in PROCEDURE binding with explicit target" + " at %C"); + return MATCH_ERROR; + } + + m = gfc_match_name (target_buf); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Expected binding target after '=>' at %C"); + return MATCH_ERROR; + } + target = target_buf; + } + + /* Now we should have the end. */ + m = gfc_match_eos (); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Junk after PROCEDURE declaration at %C"); + return MATCH_ERROR; + } + + /* If no target was found, it has the same name as the binding. */ + if (!target) + target = name; + + /* Get the namespace to insert the symbols into. */ + ns = block->f2k_derived; + gcc_assert (ns); + + /* See if we already have a binding with this name in the symtree which would + be an error. If a GENERIC already targetted this binding, it may be + already there but then typebound is still NULL. */ + stree = gfc_find_symtree (ns->sym_root, name); + if (stree && stree->typebound) + { + gfc_error ("There's already a procedure with binding name '%s' for the" + " derived type '%s' at %C", name, block->name); + return MATCH_ERROR; + } + + /* Insert it and set attributes. */ + if (gfc_get_sym_tree (name, ns, &stree)) + return MATCH_ERROR; + if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific)) + return MATCH_ERROR; + gfc_set_sym_referenced (tb->u.specific->n.sym); + stree->typebound = tb; + + return MATCH_YES; + } + + + /* Match a GENERIC procedure binding inside a derived type. */ + + match + gfc_match_generic (void) + { + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol* block; + gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */ + gfc_typebound_proc* tb; + gfc_symtree* st; + gfc_namespace* ns; + match m; + + /* Check current state. */ + if (gfc_current_state () == COMP_DERIVED) + { + gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS"); + return MATCH_ERROR; + } + if (gfc_current_state () != COMP_DERIVED_CONTAINS) + return MATCH_NO; + block = gfc_state_stack->previous->sym; + ns = block->f2k_derived; + gcc_assert (block && ns); + + /* See if we get an access-specifier. */ + m = match_binding_attributes (&tbattr, true); + if (m == MATCH_ERROR) + goto error; + + /* Now the colons, those are required. */ + if (gfc_match (" ::") != MATCH_YES) + { + gfc_error ("Expected '::' at %C"); + goto error; + } + + /* The binding name and =>. */ + m = gfc_match (" %n =>", name); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + { + gfc_error ("Expected generic name at %C"); + goto error; + } + + /* If there's already something with this name, check that it is another + GENERIC and then extend that rather than build a new node. */ + st = gfc_find_symtree (ns->sym_root, name); + if (st) + { + if (!st->typebound || !st->typebound->is_generic) + { + gfc_error ("There's already a non-generic procedure with binding name" + " '%s' for the derived type '%s' at %C", + name, block->name); + goto error; + } + + tb = st->typebound; + if (tb->access != tbattr.access) + { + gfc_error ("Binding at %C must have the same access as already" + " defined binding '%s'", name); + goto error; + } + } + else + { + if (gfc_get_sym_tree (name, ns, &st)) + return MATCH_ERROR; + + st->typebound = tb = gfc_get_typebound_proc (); + tb->where = gfc_current_locus; + tb->access = tbattr.access; + tb->is_generic = 1; + tb->u.generic = NULL; + } + + /* Now, match all following names as specific targets. */ + do + { + gfc_symtree* target_st; + gfc_tbp_generic* target; + + m = gfc_match_name (name); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + { + gfc_error ("Expected specific binding name at %C"); + goto error; + } + + if (gfc_get_sym_tree (name, ns, &target_st)) + goto error; + + /* See if this is a duplicate specification. */ + for (target = tb->u.generic; target; target = target->next) + if (target_st == target->specific_st) + { + gfc_error ("'%s' already defined as specific binding for the" + " generic '%s' at %C", name, st->n.sym->name); + goto error; + } + + gfc_set_sym_referenced (target_st->n.sym); + + target = gfc_get_tbp_generic (); + target->specific_st = target_st; + target->specific = NULL; + target->next = tb->u.generic; + tb->u.generic = target; + } + while (gfc_match (" ,") == MATCH_YES); + + /* Here should be the end. */ + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after GENERIC binding at %C"); + goto error; + } + + return MATCH_YES; + + error: + return MATCH_ERROR; + } + + + /* Match a FINAL declaration inside a derived type. */ + + match + gfc_match_final_decl (void) + { + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol* sym; + match m; + gfc_namespace* module_ns; + bool first, last; + gfc_symbol* block; + + if (gfc_state_stack->state != COMP_DERIVED_CONTAINS) + { + gfc_error ("FINAL declaration at %C must be inside a derived type " + "CONTAINS section"); + return MATCH_ERROR; + } + + block = gfc_state_stack->previous->sym; + gcc_assert (block); + + if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous + || gfc_state_stack->previous->previous->state != COMP_MODULE) + { + gfc_error ("Derived type declaration with FINAL at %C must be in the" + " specification part of a MODULE"); + return MATCH_ERROR; + } + + module_ns = gfc_current_ns; + gcc_assert (module_ns); + gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE); + + /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */ + if (gfc_match (" ::") == MATCH_ERROR) + return MATCH_ERROR; + + /* Match the sequence of procedure names. */ + first = true; + last = false; + do + { + gfc_finalizer* f; + + if (first && gfc_match_eos () == MATCH_YES) + { + gfc_error ("Empty FINAL at %C"); + return MATCH_ERROR; + } + + m = gfc_match_name (name); + if (m == MATCH_NO) + { + gfc_error ("Expected module procedure name at %C"); + return MATCH_ERROR; + } + else if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match_eos () == MATCH_YES) + last = true; + if (!last && gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected ',' at %C"); + return MATCH_ERROR; + } + + if (gfc_get_symbol (name, module_ns, &sym)) + { + gfc_error ("Unknown procedure name \"%s\" at %C", name); + return MATCH_ERROR; + } + + /* Mark the symbol as module procedure. */ + if (sym->attr.proc != PROC_MODULE + && gfc_add_procedure (&sym->attr, PROC_MODULE, + sym->name, NULL) == FAILURE) + return MATCH_ERROR; + + /* Check if we already have this symbol in the list, this is an error. */ + for (f = block->f2k_derived->finalizers; f; f = f->next) + if (f->proc_sym == sym) + { + gfc_error ("'%s' at %C is already defined as FINAL procedure!", + name); + return MATCH_ERROR; + } + + /* Add this symbol to the list of finalizers. */ + gcc_assert (block->f2k_derived); + ++sym->refs; + f = XCNEW (gfc_finalizer); + f->proc_sym = sym; + f->proc_tree = NULL; + f->where = gfc_current_locus; + f->next = block->f2k_derived->finalizers; + block->f2k_derived->finalizers = f; + + first = false; + } + while (!last); + + return MATCH_YES; + } diff -Nrcpad gcc-4.3.3/gcc/fortran/dependency.c gcc-4.4.0/gcc/fortran/dependency.c *** gcc-4.3.3/gcc/fortran/dependency.c Wed Jan 14 20:53:18 2009 --- gcc-4.4.0/gcc/fortran/dependency.c Fri Jan 9 23:47:55 2009 *************** *** 1,5 **** /* Dependency analysis ! Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook --- 1,5 ---- /* Dependency analysis ! Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. Contributed by Paul Brook *************** typedef enum *** 37,43 **** { GFC_DEP_ERROR, GFC_DEP_EQUAL, /* Identical Ranges. */ ! GFC_DEP_FORWARD, /* eg. a(1:3), a(2:4). */ GFC_DEP_OVERLAP, /* May overlap in some other way. */ GFC_DEP_NODEP /* Distinct ranges. */ } --- 37,43 ---- { GFC_DEP_ERROR, GFC_DEP_EQUAL, /* Identical Ranges. */ ! GFC_DEP_FORWARD, /* e.g., a(1:3), a(2:4). */ GFC_DEP_OVERLAP, /* May overlap in some other way. */ GFC_DEP_NODEP /* Distinct ranges. */ } *************** gfc_dep_compare_expr (gfc_expr *e1, gfc_ *** 76,90 **** int i; if (e1->expr_type == EXPR_OP ! && (e1->value.op.operator == INTRINSIC_UPLUS ! || e1->value.op.operator == INTRINSIC_PARENTHESES)) return gfc_dep_compare_expr (e1->value.op.op1, e2); if (e2->expr_type == EXPR_OP ! && (e2->value.op.operator == INTRINSIC_UPLUS ! || e2->value.op.operator == INTRINSIC_PARENTHESES)) return gfc_dep_compare_expr (e1, e2->value.op.op1); ! if (e1->expr_type == EXPR_OP && e1->value.op.operator == INTRINSIC_PLUS) { /* Compare X+C vs. X. */ if (e1->value.op.op2->expr_type == EXPR_CONSTANT --- 76,90 ---- int i; if (e1->expr_type == EXPR_OP ! && (e1->value.op.op == INTRINSIC_UPLUS ! || e1->value.op.op == INTRINSIC_PARENTHESES)) return gfc_dep_compare_expr (e1->value.op.op1, e2); if (e2->expr_type == EXPR_OP ! && (e2->value.op.op == INTRINSIC_UPLUS ! || e2->value.op.op == INTRINSIC_PARENTHESES)) return gfc_dep_compare_expr (e1, e2->value.op.op1); ! if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) { /* Compare X+C vs. X. */ if (e1->value.op.op2->expr_type == EXPR_CONSTANT *************** gfc_dep_compare_expr (gfc_expr *e1, gfc_ *** 93,99 **** return mpz_sgn (e1->value.op.op2->value.integer); /* Compare P+Q vs. R+S. */ ! if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_PLUS) { int l, r; --- 93,99 ---- return mpz_sgn (e1->value.op.op2->value.integer); /* Compare P+Q vs. R+S. */ ! if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) { int l, r; *************** gfc_dep_compare_expr (gfc_expr *e1, gfc_ *** 126,132 **** } /* Compare X vs. X+C. */ ! if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_PLUS) { if (e2->value.op.op2->expr_type == EXPR_CONSTANT && e2->value.op.op2->ts.type == BT_INTEGER --- 126,132 ---- } /* Compare X vs. X+C. */ ! if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) { if (e2->value.op.op2->expr_type == EXPR_CONSTANT && e2->value.op.op2->ts.type == BT_INTEGER *************** gfc_dep_compare_expr (gfc_expr *e1, gfc_ *** 135,141 **** } /* Compare X-C vs. X. */ ! if (e1->expr_type == EXPR_OP && e1->value.op.operator == INTRINSIC_MINUS) { if (e1->value.op.op2->expr_type == EXPR_CONSTANT && e1->value.op.op2->ts.type == BT_INTEGER --- 135,141 ---- } /* Compare X-C vs. X. */ ! if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) { if (e1->value.op.op2->expr_type == EXPR_CONSTANT && e1->value.op.op2->ts.type == BT_INTEGER *************** gfc_dep_compare_expr (gfc_expr *e1, gfc_ *** 143,149 **** return -mpz_sgn (e1->value.op.op2->value.integer); /* Compare P-Q vs. R-S. */ ! if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_MINUS) { int l, r; --- 143,149 ---- return -mpz_sgn (e1->value.op.op2->value.integer); /* Compare P-Q vs. R-S. */ ! if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) { int l, r; *************** gfc_dep_compare_expr (gfc_expr *e1, gfc_ *** 163,169 **** } /* Compare X vs. X-C. */ ! if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_MINUS) { if (e2->value.op.op2->expr_type == EXPR_CONSTANT && e2->value.op.op2->ts.type == BT_INTEGER --- 163,169 ---- } /* Compare X vs. X-C. */ ! if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) { if (e2->value.op.op2->expr_type == EXPR_CONSTANT && e2->value.op.op2->ts.type == BT_INTEGER *************** gfc_dep_compare_expr (gfc_expr *e1, gfc_ *** 196,202 **** case EXPR_OP: /* Intrinsic operators are the same if their operands are the same. */ ! if (e1->value.op.operator != e2->value.op.operator) return -2; if (e1->value.op.op2 == 0) { --- 196,202 ---- case EXPR_OP: /* Intrinsic operators are the same if their operands are the same. */ ! if (e1->value.op.op != e2->value.op.op) return -2; if (e1->value.op.op2 == 0) { *************** gfc_ref_needs_temporary_p (gfc_ref *ref) *** 422,439 **** } ! static int gfc_is_data_pointer (gfc_expr *e) { gfc_ref *ref; ! if (e->expr_type != EXPR_VARIABLE) return 0; if (e->symtree->n.sym->attr.pointer) return 1; for (ref = e->ref; ref; ref = ref->next) ! if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) return 1; return 0; --- 422,443 ---- } ! int gfc_is_data_pointer (gfc_expr *e) { gfc_ref *ref; ! if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION) return 0; + /* No subreference if it is a function */ + gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref); + if (e->symtree->n.sym->attr.pointer) return 1; + for (ref = e->ref; ref; ref = ref->next) ! if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) return 1; return 0; *************** gfc_check_fncall_dependency (gfc_expr *o *** 603,609 **** /* Return 1 if e1 and e2 are equivalenced arrays, either ! directly or indirectly; ie. equivalence (a,b) for a and b or equivalence (a,c),(b,c). This function uses the equiv_ lists, generated in trans-common(add_equivalences), that are guaranteed to pick up indirect equivalences. We explicitly --- 607,613 ---- /* Return 1 if e1 and e2 are equivalenced arrays, either ! directly or indirectly; i.e., equivalence (a,b) for a and b or equivalence (a,c),(b,c). This function uses the equiv_ lists, generated in trans-common(add_equivalences), that are guaranteed to pick up indirect equivalences. We explicitly *************** gfc_dep_resolver (gfc_ref *lref, gfc_ref *** 1259,1265 **** while (lref && rref) { /* We're resolving from the same base symbol, so both refs should be ! the same type. We traverse the reference chain intil we find ranges that are not equal. */ gcc_assert (lref->type == rref->type); switch (lref->type) --- 1263,1269 ---- while (lref && rref) { /* We're resolving from the same base symbol, so both refs should be ! the same type. We traverse the reference chain until we find ranges that are not equal. */ gcc_assert (lref->type == rref->type); switch (lref->type) diff -Nrcpad gcc-4.3.3/gcc/fortran/dependency.h gcc-4.4.0/gcc/fortran/dependency.h *** gcc-4.3.3/gcc/fortran/dependency.h Mon Nov 24 12:13:59 2008 --- gcc-4.4.0/gcc/fortran/dependency.h Sun Nov 16 22:45:10 2008 *************** *** 1,5 **** /* Header for dependency analysis ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Paul Brook --- 1,5 ---- /* Header for dependency analysis ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Paul Brook diff -Nrcpad gcc-4.3.3/gcc/fortran/dump-parse-tree.c gcc-4.4.0/gcc/fortran/dump-parse-tree.c *** gcc-4.3.3/gcc/fortran/dump-parse-tree.c Sun Dec 16 11:34:08 2007 --- gcc-4.4.0/gcc/fortran/dump-parse-tree.c Tue Sep 2 08:13:21 2008 *************** *** 1,5 **** /* Parse tree dumper ! Copyright (C) 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Steven Bosscher --- 1,5 ---- /* Parse tree dumper ! Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Steven Bosscher *************** along with GCC; see the file COPYING3. *** 37,42 **** --- 37,52 ---- /* Keep track of indentation for symbol tree dumps. */ static int show_level = 0; + /* The file handle we're dumping to is kept in a static variable. This + is not too cool, but it avoids a lot of passing it around. */ + static FILE *dumpfile; + + /* Forward declaration of some of the functions. */ + static void show_expr (gfc_expr *p); + static void show_code_node (int, gfc_code *); + static void show_namespace (gfc_namespace *ns); + + /* Do indentation for a specific level. */ static inline void *************** code_indent (int level, gfc_st_label *la *** 45,56 **** int i; if (label != NULL) ! gfc_status ("%-5d ", label->value); else ! gfc_status (" "); for (i = 0; i < 2 * level; i++) ! gfc_status_char (' '); } --- 55,66 ---- int i; if (label != NULL) ! fprintf (dumpfile, "%-5d ", label->value); else ! fputs (" ", dumpfile); for (i = 0; i < 2 * level; i++) ! fputc (' ', dumpfile); } *************** code_indent (int level, gfc_st_label *la *** 60,137 **** static inline void show_indent (void) { ! gfc_status ("\n"); code_indent (show_level, NULL); } /* Show type-specific information. */ ! void ! gfc_show_typespec (gfc_typespec *ts) { ! gfc_status ("(%s ", gfc_basic_typename (ts->type)); switch (ts->type) { case BT_DERIVED: ! gfc_status ("%s", ts->derived->name); break; case BT_CHARACTER: ! gfc_show_expr (ts->cl->length); break; default: ! gfc_status ("%d", ts->kind); break; } ! gfc_status (")"); } /* Show an actual argument list. */ ! void ! gfc_show_actual_arglist (gfc_actual_arglist *a) { ! gfc_status ("("); for (; a; a = a->next) { ! gfc_status_char ('('); if (a->name != NULL) ! gfc_status ("%s = ", a->name); if (a->expr != NULL) ! gfc_show_expr (a->expr); else ! gfc_status ("(arg not-present)"); ! gfc_status_char (')'); if (a->next != NULL) ! gfc_status (" "); } ! gfc_status (")"); } /* Show a gfc_array_spec array specification structure. */ ! void ! gfc_show_array_spec (gfc_array_spec *as) { const char *c; int i; if (as == NULL) { ! gfc_status ("()"); return; } ! gfc_status ("(%d", as->rank); if (as->rank != 0) { --- 70,147 ---- static inline void show_indent (void) { ! fputc ('\n', dumpfile); code_indent (show_level, NULL); } /* Show type-specific information. */ ! static void ! show_typespec (gfc_typespec *ts) { ! fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type)); switch (ts->type) { case BT_DERIVED: ! fprintf (dumpfile, "%s", ts->derived->name); break; case BT_CHARACTER: ! show_expr (ts->cl->length); break; default: ! fprintf (dumpfile, "%d", ts->kind); break; } ! fputc (')', dumpfile); } /* Show an actual argument list. */ ! static void ! show_actual_arglist (gfc_actual_arglist *a) { ! fputc ('(', dumpfile); for (; a; a = a->next) { ! fputc ('(', dumpfile); if (a->name != NULL) ! fprintf (dumpfile, "%s = ", a->name); if (a->expr != NULL) ! show_expr (a->expr); else ! fputs ("(arg not-present)", dumpfile); ! fputc (')', dumpfile); if (a->next != NULL) ! fputc (' ', dumpfile); } ! fputc (')', dumpfile); } /* Show a gfc_array_spec array specification structure. */ ! static void ! show_array_spec (gfc_array_spec *as) { const char *c; int i; if (as == NULL) { ! fputs ("()", dumpfile); return; } ! fprintf (dumpfile, "(%d", as->rank); if (as->rank != 0) { *************** gfc_show_array_spec (gfc_array_spec *as) *** 142,178 **** case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break; case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break; default: ! gfc_internal_error ("gfc_show_array_spec(): Unhandled array shape " "type."); } ! gfc_status (" %s ", c); for (i = 0; i < as->rank; i++) { ! gfc_show_expr (as->lower[i]); ! gfc_status_char (' '); ! gfc_show_expr (as->upper[i]); ! gfc_status_char (' '); } } ! gfc_status (")"); } /* Show a gfc_array_ref array reference structure. */ ! void ! gfc_show_array_ref (gfc_array_ref * ar) { int i; ! gfc_status_char ('('); switch (ar->type) { case AR_FULL: ! gfc_status ("FULL"); break; case AR_SECTION: --- 152,188 ---- case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break; case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break; default: ! gfc_internal_error ("show_array_spec(): Unhandled array shape " "type."); } ! fprintf (dumpfile, " %s ", c); for (i = 0; i < as->rank; i++) { ! show_expr (as->lower[i]); ! fputc (' ', dumpfile); ! show_expr (as->upper[i]); ! fputc (' ', dumpfile); } } ! fputc (')', dumpfile); } /* Show a gfc_array_ref array reference structure. */ ! static void ! show_array_ref (gfc_array_ref * ar) { int i; ! fputc ('(', dumpfile); switch (ar->type) { case AR_FULL: ! fputs ("FULL", dumpfile); break; case AR_SECTION: *************** gfc_show_array_ref (gfc_array_ref * ar) *** 186,328 **** bound and the stride, if they're present. */ if (ar->start[i] != NULL) ! gfc_show_expr (ar->start[i]); if (ar->dimen_type[i] == DIMEN_RANGE) { ! gfc_status_char (':'); if (ar->end[i] != NULL) ! gfc_show_expr (ar->end[i]); if (ar->stride[i] != NULL) { ! gfc_status_char (':'); ! gfc_show_expr (ar->stride[i]); } } if (i != ar->dimen - 1) ! gfc_status (" , "); } break; case AR_ELEMENT: for (i = 0; i < ar->dimen; i++) { ! gfc_show_expr (ar->start[i]); if (i != ar->dimen - 1) ! gfc_status (" , "); } break; case AR_UNKNOWN: ! gfc_status ("UNKNOWN"); break; default: ! gfc_internal_error ("gfc_show_array_ref(): Unknown array reference"); } ! gfc_status_char (')'); } /* Show a list of gfc_ref structures. */ ! void ! gfc_show_ref (gfc_ref *p) { for (; p; p = p->next) switch (p->type) { case REF_ARRAY: ! gfc_show_array_ref (&p->u.ar); break; case REF_COMPONENT: ! gfc_status (" %% %s", p->u.c.component->name); break; case REF_SUBSTRING: ! gfc_status_char ('('); ! gfc_show_expr (p->u.ss.start); ! gfc_status_char (':'); ! gfc_show_expr (p->u.ss.end); ! gfc_status_char (')'); break; default: ! gfc_internal_error ("gfc_show_ref(): Bad component code"); } } /* Display a constructor. Works recursively for array constructors. */ ! void ! gfc_show_constructor (gfc_constructor *c) { for (; c; c = c->next) { if (c->iterator == NULL) ! gfc_show_expr (c->expr); else { ! gfc_status_char ('('); ! gfc_show_expr (c->expr); ! gfc_status_char (' '); ! gfc_show_expr (c->iterator->var); ! gfc_status_char ('='); ! gfc_show_expr (c->iterator->start); ! gfc_status_char (','); ! gfc_show_expr (c->iterator->end); ! gfc_status_char (','); ! gfc_show_expr (c->iterator->step); ! gfc_status_char (')'); } if (c->next != NULL) ! gfc_status (" , "); } } static void ! show_char_const (const char *c, int length) { int i; ! gfc_status_char ('\''); for (i = 0; i < length; i++) { if (c[i] == '\'') ! gfc_status ("''"); ! else if (ISPRINT (c[i])) ! gfc_status_char (c[i]); else ! { ! gfc_status ("' // ACHAR("); ! printf ("%d", c[i]); ! gfc_status (") // '"); ! } } ! gfc_status_char ('\''); } /* Show an expression. */ ! void ! gfc_show_expr (gfc_expr *p) { const char *c; int i; if (p == NULL) { ! gfc_status ("()"); return; } --- 196,348 ---- bound and the stride, if they're present. */ if (ar->start[i] != NULL) ! show_expr (ar->start[i]); if (ar->dimen_type[i] == DIMEN_RANGE) { ! fputc (':', dumpfile); if (ar->end[i] != NULL) ! show_expr (ar->end[i]); if (ar->stride[i] != NULL) { ! fputc (':', dumpfile); ! show_expr (ar->stride[i]); } } if (i != ar->dimen - 1) ! fputs (" , ", dumpfile); } break; case AR_ELEMENT: for (i = 0; i < ar->dimen; i++) { ! show_expr (ar->start[i]); if (i != ar->dimen - 1) ! fputs (" , ", dumpfile); } break; case AR_UNKNOWN: ! fputs ("UNKNOWN", dumpfile); break; default: ! gfc_internal_error ("show_array_ref(): Unknown array reference"); } ! fputc (')', dumpfile); } /* Show a list of gfc_ref structures. */ ! static void ! show_ref (gfc_ref *p) { for (; p; p = p->next) switch (p->type) { case REF_ARRAY: ! show_array_ref (&p->u.ar); break; case REF_COMPONENT: ! fprintf (dumpfile, " %% %s", p->u.c.component->name); break; case REF_SUBSTRING: ! fputc ('(', dumpfile); ! show_expr (p->u.ss.start); ! fputc (':', dumpfile); ! show_expr (p->u.ss.end); ! fputc (')', dumpfile); break; default: ! gfc_internal_error ("show_ref(): Bad component code"); } } /* Display a constructor. Works recursively for array constructors. */ ! static void ! show_constructor (gfc_constructor *c) { for (; c; c = c->next) { if (c->iterator == NULL) ! show_expr (c->expr); else { ! fputc ('(', dumpfile); ! show_expr (c->expr); ! fputc (' ', dumpfile); ! show_expr (c->iterator->var); ! fputc ('=', dumpfile); ! show_expr (c->iterator->start); ! fputc (',', dumpfile); ! show_expr (c->iterator->end); ! fputc (',', dumpfile); ! show_expr (c->iterator->step); ! fputc (')', dumpfile); } if (c->next != NULL) ! fputs (" , ", dumpfile); } } static void ! show_char_const (const gfc_char_t *c, int length) { int i; ! fputc ('\'', dumpfile); for (i = 0; i < length; i++) { if (c[i] == '\'') ! fputs ("''", dumpfile); else ! fputs (gfc_print_wide_char (c[i]), dumpfile); } ! fputc ('\'', dumpfile); ! } ! ! ! /* Show a component-call expression. */ ! ! static void ! show_compcall (gfc_expr* p) ! { ! gcc_assert (p->expr_type == EXPR_COMPCALL); ! ! fprintf (dumpfile, "%s", p->symtree->n.sym->name); ! show_ref (p->ref); ! fprintf (dumpfile, "%s", p->value.compcall.name); ! ! show_actual_arglist (p->value.compcall.actual); } + /* Show an expression. */ ! static void ! show_expr (gfc_expr *p) { const char *c; int i; if (p == NULL) { ! fputs ("()", dumpfile); return; } *************** gfc_show_expr (gfc_expr *p) *** 330,354 **** { case EXPR_SUBSTRING: show_char_const (p->value.character.string, p->value.character.length); ! gfc_show_ref (p->ref); break; case EXPR_STRUCTURE: ! gfc_status ("%s(", p->ts.derived->name); ! gfc_show_constructor (p->value.constructor); ! gfc_status_char (')'); break; case EXPR_ARRAY: ! gfc_status ("(/ "); ! gfc_show_constructor (p->value.constructor); ! gfc_status (" /)"); ! gfc_show_ref (p->ref); break; case EXPR_NULL: ! gfc_status ("NULL()"); break; case EXPR_CONSTANT: --- 350,374 ---- { case EXPR_SUBSTRING: show_char_const (p->value.character.string, p->value.character.length); ! show_ref (p->ref); break; case EXPR_STRUCTURE: ! fprintf (dumpfile, "%s(", p->ts.derived->name); ! show_constructor (p->value.constructor); ! fputc (')', dumpfile); break; case EXPR_ARRAY: ! fputs ("(/ ", dumpfile); ! show_constructor (p->value.constructor); ! fputs (" /)", dumpfile); ! show_ref (p->ref); break; case EXPR_NULL: ! fputs ("NULL()", dumpfile); break; case EXPR_CONSTANT: *************** gfc_show_expr (gfc_expr *p) *** 358,377 **** mpz_out_str (stdout, 10, p->value.integer); if (p->ts.kind != gfc_default_integer_kind) ! gfc_status ("_%d", p->ts.kind); break; case BT_LOGICAL: if (p->value.logical) ! gfc_status (".true."); else ! gfc_status (".false."); break; case BT_REAL: mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE); if (p->ts.kind != gfc_default_real_kind) ! gfc_status ("_%d", p->ts.kind); break; case BT_CHARACTER: --- 378,397 ---- mpz_out_str (stdout, 10, p->value.integer); if (p->ts.kind != gfc_default_integer_kind) ! fprintf (dumpfile, "_%d", p->ts.kind); break; case BT_LOGICAL: if (p->value.logical) ! fputs (".true.", dumpfile); else ! fputs (".false.", dumpfile); break; case BT_REAL: mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE); if (p->ts.kind != gfc_default_real_kind) ! fprintf (dumpfile, "_%d", p->ts.kind); break; case BT_CHARACTER: *************** gfc_show_expr (gfc_expr *p) *** 380,653 **** break; case BT_COMPLEX: ! gfc_status ("(complex "); mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE); if (p->ts.kind != gfc_default_complex_kind) ! gfc_status ("_%d", p->ts.kind); ! gfc_status (" "); mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE); if (p->ts.kind != gfc_default_complex_kind) ! gfc_status ("_%d", p->ts.kind); ! gfc_status (")"); break; case BT_HOLLERITH: ! gfc_status ("%dH", p->representation.length); c = p->representation.string; for (i = 0; i < p->representation.length; i++, c++) { ! gfc_status_char (*c); } break; default: ! gfc_status ("???"); break; } if (p->representation.string) { ! gfc_status (" {"); c = p->representation.string; for (i = 0; i < p->representation.length; i++, c++) { ! gfc_status ("%.2x", (unsigned int) *c); if (i < p->representation.length - 1) ! gfc_status_char (','); } ! gfc_status_char ('}'); } break; case EXPR_VARIABLE: if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name) ! gfc_status ("%s:", p->symtree->n.sym->ns->proc_name->name); ! gfc_status ("%s", p->symtree->n.sym->name); ! gfc_show_ref (p->ref); break; case EXPR_OP: ! gfc_status ("("); ! switch (p->value.op.operator) { case INTRINSIC_UPLUS: ! gfc_status ("U+ "); break; case INTRINSIC_UMINUS: ! gfc_status ("U- "); break; case INTRINSIC_PLUS: ! gfc_status ("+ "); break; case INTRINSIC_MINUS: ! gfc_status ("- "); break; case INTRINSIC_TIMES: ! gfc_status ("* "); break; case INTRINSIC_DIVIDE: ! gfc_status ("/ "); break; case INTRINSIC_POWER: ! gfc_status ("** "); break; case INTRINSIC_CONCAT: ! gfc_status ("// "); break; case INTRINSIC_AND: ! gfc_status ("AND "); break; case INTRINSIC_OR: ! gfc_status ("OR "); break; case INTRINSIC_EQV: ! gfc_status ("EQV "); break; case INTRINSIC_NEQV: ! gfc_status ("NEQV "); break; case INTRINSIC_EQ: case INTRINSIC_EQ_OS: ! gfc_status ("= "); break; case INTRINSIC_NE: case INTRINSIC_NE_OS: ! gfc_status ("/= "); break; case INTRINSIC_GT: case INTRINSIC_GT_OS: ! gfc_status ("> "); break; case INTRINSIC_GE: case INTRINSIC_GE_OS: ! gfc_status (">= "); break; case INTRINSIC_LT: case INTRINSIC_LT_OS: ! gfc_status ("< "); break; case INTRINSIC_LE: case INTRINSIC_LE_OS: ! gfc_status ("<= "); break; case INTRINSIC_NOT: ! gfc_status ("NOT "); break; case INTRINSIC_PARENTHESES: ! gfc_status ("parens"); break; default: gfc_internal_error ! ("gfc_show_expr(): Bad intrinsic in expression!"); } ! gfc_show_expr (p->value.op.op1); if (p->value.op.op2) { ! gfc_status (" "); ! gfc_show_expr (p->value.op.op2); } ! gfc_status (")"); break; case EXPR_FUNCTION: if (p->value.function.name == NULL) { ! gfc_status ("%s[", p->symtree->n.sym->name); ! gfc_show_actual_arglist (p->value.function.actual); ! gfc_status_char (']'); } else { ! gfc_status ("%s[[", p->value.function.name); ! gfc_show_actual_arglist (p->value.function.actual); ! gfc_status_char (']'); ! gfc_status_char (']'); } break; default: ! gfc_internal_error ("gfc_show_expr(): Don't know how to show expr"); } } - /* Show an expression for diagnostic purposes. */ - void - gfc_show_expr_n (const char * msg, gfc_expr *e) - { - if (msg) - gfc_status (msg); - gfc_show_expr (e); - gfc_status_char ('\n'); - } - /* Show symbol attributes. The flavor and intent are followed by whatever single bit attributes are present. */ ! void ! gfc_show_attr (symbol_attribute *attr) { ! gfc_status ("(%s %s %s %s %s", gfc_code2string (flavors, attr->flavor), ! gfc_intent_string (attr->intent), ! gfc_code2string (access_types, attr->access), ! gfc_code2string (procedures, attr->proc), ! gfc_code2string (save_status, attr->save)); if (attr->allocatable) ! gfc_status (" ALLOCATABLE"); if (attr->dimension) ! gfc_status (" DIMENSION"); if (attr->external) ! gfc_status (" EXTERNAL"); if (attr->intrinsic) ! gfc_status (" INTRINSIC"); if (attr->optional) ! gfc_status (" OPTIONAL"); if (attr->pointer) ! gfc_status (" POINTER"); ! if (attr->protected) ! gfc_status (" PROTECTED"); if (attr->value) ! gfc_status (" VALUE"); if (attr->volatile_) ! gfc_status (" VOLATILE"); if (attr->threadprivate) ! gfc_status (" THREADPRIVATE"); if (attr->target) ! gfc_status (" TARGET"); if (attr->dummy) ! gfc_status (" DUMMY"); if (attr->result) ! gfc_status (" RESULT"); if (attr->entry) ! gfc_status (" ENTRY"); if (attr->is_bind_c) ! gfc_status (" BIND(C)"); if (attr->data) ! gfc_status (" DATA"); if (attr->use_assoc) ! gfc_status (" USE-ASSOC"); if (attr->in_namelist) ! gfc_status (" IN-NAMELIST"); if (attr->in_common) ! gfc_status (" IN-COMMON"); if (attr->abstract) ! gfc_status (" ABSTRACT INTERFACE"); if (attr->function) ! gfc_status (" FUNCTION"); if (attr->subroutine) ! gfc_status (" SUBROUTINE"); if (attr->implicit_type) ! gfc_status (" IMPLICIT-TYPE"); if (attr->sequence) ! gfc_status (" SEQUENCE"); if (attr->elemental) ! gfc_status (" ELEMENTAL"); if (attr->pure) ! gfc_status (" PURE"); if (attr->recursive) ! gfc_status (" RECURSIVE"); ! gfc_status (")"); } /* Show components of a derived type. */ ! void ! gfc_show_components (gfc_symbol *sym) { gfc_component *c; for (c = sym->components; c; c = c->next) { ! gfc_status ("(%s ", c->name); ! gfc_show_typespec (&c->ts); ! if (c->pointer) ! gfc_status (" POINTER"); ! if (c->dimension) ! gfc_status (" DIMENSION"); ! gfc_status_char (' '); ! gfc_show_array_spec (c->as); ! if (c->access) ! gfc_status (" %s", gfc_code2string (access_types, c->access)); ! gfc_status (")"); if (c->next != NULL) ! gfc_status_char (' '); } } --- 400,738 ---- break; case BT_COMPLEX: ! fputs ("(complex ", dumpfile); mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE); if (p->ts.kind != gfc_default_complex_kind) ! fprintf (dumpfile, "_%d", p->ts.kind); ! fputc (' ', dumpfile); mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE); if (p->ts.kind != gfc_default_complex_kind) ! fprintf (dumpfile, "_%d", p->ts.kind); ! fputc (')', dumpfile); break; case BT_HOLLERITH: ! fprintf (dumpfile, "%dH", p->representation.length); c = p->representation.string; for (i = 0; i < p->representation.length; i++, c++) { ! fputc (*c, dumpfile); } break; default: ! fputs ("???", dumpfile); break; } if (p->representation.string) { ! fputs (" {", dumpfile); c = p->representation.string; for (i = 0; i < p->representation.length; i++, c++) { ! fprintf (dumpfile, "%.2x", (unsigned int) *c); if (i < p->representation.length - 1) ! fputc (',', dumpfile); } ! fputc ('}', dumpfile); } break; case EXPR_VARIABLE: if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name) ! fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name); ! fprintf (dumpfile, "%s", p->symtree->n.sym->name); ! show_ref (p->ref); break; case EXPR_OP: ! fputc ('(', dumpfile); ! switch (p->value.op.op) { case INTRINSIC_UPLUS: ! fputs ("U+ ", dumpfile); break; case INTRINSIC_UMINUS: ! fputs ("U- ", dumpfile); break; case INTRINSIC_PLUS: ! fputs ("+ ", dumpfile); break; case INTRINSIC_MINUS: ! fputs ("- ", dumpfile); break; case INTRINSIC_TIMES: ! fputs ("* ", dumpfile); break; case INTRINSIC_DIVIDE: ! fputs ("/ ", dumpfile); break; case INTRINSIC_POWER: ! fputs ("** ", dumpfile); break; case INTRINSIC_CONCAT: ! fputs ("// ", dumpfile); break; case INTRINSIC_AND: ! fputs ("AND ", dumpfile); break; case INTRINSIC_OR: ! fputs ("OR ", dumpfile); break; case INTRINSIC_EQV: ! fputs ("EQV ", dumpfile); break; case INTRINSIC_NEQV: ! fputs ("NEQV ", dumpfile); break; case INTRINSIC_EQ: case INTRINSIC_EQ_OS: ! fputs ("= ", dumpfile); break; case INTRINSIC_NE: case INTRINSIC_NE_OS: ! fputs ("/= ", dumpfile); break; case INTRINSIC_GT: case INTRINSIC_GT_OS: ! fputs ("> ", dumpfile); break; case INTRINSIC_GE: case INTRINSIC_GE_OS: ! fputs (">= ", dumpfile); break; case INTRINSIC_LT: case INTRINSIC_LT_OS: ! fputs ("< ", dumpfile); break; case INTRINSIC_LE: case INTRINSIC_LE_OS: ! fputs ("<= ", dumpfile); break; case INTRINSIC_NOT: ! fputs ("NOT ", dumpfile); break; case INTRINSIC_PARENTHESES: ! fputs ("parens", dumpfile); break; default: gfc_internal_error ! ("show_expr(): Bad intrinsic in expression!"); } ! show_expr (p->value.op.op1); if (p->value.op.op2) { ! fputc (' ', dumpfile); ! show_expr (p->value.op.op2); } ! fputc (')', dumpfile); break; case EXPR_FUNCTION: if (p->value.function.name == NULL) { ! fprintf (dumpfile, "%s[", p->symtree->n.sym->name); ! show_actual_arglist (p->value.function.actual); ! fputc (']', dumpfile); } else { ! fprintf (dumpfile, "%s[[", p->value.function.name); ! show_actual_arglist (p->value.function.actual); ! fputc (']', dumpfile); ! fputc (']', dumpfile); } break; + case EXPR_COMPCALL: + show_compcall (p); + break; + default: ! gfc_internal_error ("show_expr(): Don't know how to show expr"); } } /* Show symbol attributes. The flavor and intent are followed by whatever single bit attributes are present. */ ! static void ! show_attr (symbol_attribute *attr) { ! fprintf (dumpfile, "(%s %s %s %s %s", ! gfc_code2string (flavors, attr->flavor), ! gfc_intent_string (attr->intent), ! gfc_code2string (access_types, attr->access), ! gfc_code2string (procedures, attr->proc), ! gfc_code2string (save_status, attr->save)); if (attr->allocatable) ! fputs (" ALLOCATABLE", dumpfile); if (attr->dimension) ! fputs (" DIMENSION", dumpfile); if (attr->external) ! fputs (" EXTERNAL", dumpfile); if (attr->intrinsic) ! fputs (" INTRINSIC", dumpfile); if (attr->optional) ! fputs (" OPTIONAL", dumpfile); if (attr->pointer) ! fputs (" POINTER", dumpfile); ! if (attr->is_protected) ! fputs (" PROTECTED", dumpfile); if (attr->value) ! fputs (" VALUE", dumpfile); if (attr->volatile_) ! fputs (" VOLATILE", dumpfile); if (attr->threadprivate) ! fputs (" THREADPRIVATE", dumpfile); if (attr->target) ! fputs (" TARGET", dumpfile); if (attr->dummy) ! fputs (" DUMMY", dumpfile); if (attr->result) ! fputs (" RESULT", dumpfile); if (attr->entry) ! fputs (" ENTRY", dumpfile); if (attr->is_bind_c) ! fputs (" BIND(C)", dumpfile); if (attr->data) ! fputs (" DATA", dumpfile); if (attr->use_assoc) ! fputs (" USE-ASSOC", dumpfile); if (attr->in_namelist) ! fputs (" IN-NAMELIST", dumpfile); if (attr->in_common) ! fputs (" IN-COMMON", dumpfile); if (attr->abstract) ! fputs (" ABSTRACT", dumpfile); if (attr->function) ! fputs (" FUNCTION", dumpfile); if (attr->subroutine) ! fputs (" SUBROUTINE", dumpfile); if (attr->implicit_type) ! fputs (" IMPLICIT-TYPE", dumpfile); if (attr->sequence) ! fputs (" SEQUENCE", dumpfile); if (attr->elemental) ! fputs (" ELEMENTAL", dumpfile); if (attr->pure) ! fputs (" PURE", dumpfile); if (attr->recursive) ! fputs (" RECURSIVE", dumpfile); ! fputc (')', dumpfile); } /* Show components of a derived type. */ ! static void ! show_components (gfc_symbol *sym) { gfc_component *c; for (c = sym->components; c; c = c->next) { ! fprintf (dumpfile, "(%s ", c->name); ! show_typespec (&c->ts); ! if (c->attr.pointer) ! fputs (" POINTER", dumpfile); ! if (c->attr.dimension) ! fputs (" DIMENSION", dumpfile); ! fputc (' ', dumpfile); ! show_array_spec (c->as); ! if (c->attr.access) ! fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access)); ! fputc (')', dumpfile); if (c->next != NULL) ! fputc (' ', dumpfile); ! } ! } ! ! ! /* Show the f2k_derived namespace with procedure bindings. */ ! ! static void ! show_typebound (gfc_symtree* st) ! { ! if (!st->typebound) ! return; ! ! show_indent (); ! ! if (st->typebound->is_generic) ! fputs ("GENERIC", dumpfile); ! else ! { ! fputs ("PROCEDURE, ", dumpfile); ! if (st->typebound->nopass) ! fputs ("NOPASS", dumpfile); ! else ! { ! if (st->typebound->pass_arg) ! fprintf (dumpfile, "PASS(%s)", st->typebound->pass_arg); ! else ! fputs ("PASS", dumpfile); ! } ! if (st->typebound->non_overridable) ! fputs (", NON_OVERRIDABLE", dumpfile); } + + if (st->typebound->access == ACCESS_PUBLIC) + fputs (", PUBLIC", dumpfile); + else + fputs (", PRIVATE", dumpfile); + + fprintf (dumpfile, " :: %s => ", st->n.sym->name); + + if (st->typebound->is_generic) + { + gfc_tbp_generic* g; + for (g = st->typebound->u.generic; g; g = g->next) + { + fputs (g->specific_st->name, dumpfile); + if (g->next) + fputs (", ", dumpfile); + } + } + else + fputs (st->typebound->u.specific->n.sym->name, dumpfile); + } + + static void + show_f2k_derived (gfc_namespace* f2k) + { + gfc_finalizer* f; + + ++show_level; + + /* Finalizer bindings. */ + for (f = f2k->finalizers; f; f = f->next) + { + show_indent (); + fprintf (dumpfile, "FINAL %s", f->proc_sym->name); + } + + /* Type-bound procedures. */ + gfc_traverse_symtree (f2k->sym_root, &show_typebound); + + --show_level; } *************** gfc_show_components (gfc_symbol *sym) *** 656,663 **** specific interfaces associated with a generic symbol is done within that symbol. */ ! void ! gfc_show_symbol (gfc_symbol *sym) { gfc_formal_arglist *formal; gfc_interface *intr; --- 741,748 ---- specific interfaces associated with a generic symbol is done within that symbol. */ ! static void ! show_symbol (gfc_symbol *sym) { gfc_formal_arglist *formal; gfc_interface *intr; *************** gfc_show_symbol (gfc_symbol *sym) *** 667,744 **** show_indent (); ! gfc_status ("symbol %s ", sym->name); ! gfc_show_typespec (&sym->ts); ! gfc_show_attr (&sym->attr); if (sym->value) { show_indent (); ! gfc_status ("value: "); ! gfc_show_expr (sym->value); } if (sym->as) { show_indent (); ! gfc_status ("Array spec:"); ! gfc_show_array_spec (sym->as); } if (sym->generic) { show_indent (); ! gfc_status ("Generic interfaces:"); for (intr = sym->generic; intr; intr = intr->next) ! gfc_status (" %s", intr->sym->name); } if (sym->result) { show_indent (); ! gfc_status ("result: %s", sym->result->name); } if (sym->components) { show_indent (); ! gfc_status ("components: "); ! gfc_show_components (sym); } if (sym->formal) { show_indent (); ! gfc_status ("Formal arglist:"); for (formal = sym->formal; formal; formal = formal->next) { if (formal->sym != NULL) ! gfc_status (" %s", formal->sym->name); else ! gfc_status (" [Alt Return]"); } } if (sym->formal_ns) { show_indent (); ! gfc_status ("Formal namespace"); ! gfc_show_namespace (sym->formal_ns); } ! gfc_status_char ('\n'); ! } ! ! ! /* Show a symbol for diagnostic purposes. */ ! void ! gfc_show_symbol_n (const char * msg, gfc_symbol *sym) ! { ! if (msg) ! gfc_status (msg); ! gfc_show_symbol (sym); ! gfc_status_char ('\n'); } --- 752,825 ---- show_indent (); ! fprintf (dumpfile, "symbol %s ", sym->name); ! show_typespec (&sym->ts); ! show_attr (&sym->attr); if (sym->value) { show_indent (); ! fputs ("value: ", dumpfile); ! show_expr (sym->value); } if (sym->as) { show_indent (); ! fputs ("Array spec:", dumpfile); ! show_array_spec (sym->as); } if (sym->generic) { show_indent (); ! fputs ("Generic interfaces:", dumpfile); for (intr = sym->generic; intr; intr = intr->next) ! fprintf (dumpfile, " %s", intr->sym->name); } if (sym->result) { show_indent (); ! fprintf (dumpfile, "result: %s", sym->result->name); } if (sym->components) { show_indent (); ! fputs ("components: ", dumpfile); ! show_components (sym); ! } ! ! if (sym->f2k_derived) ! { ! show_indent (); ! fputs ("Procedure bindings:\n", dumpfile); ! show_f2k_derived (sym->f2k_derived); } if (sym->formal) { show_indent (); ! fputs ("Formal arglist:", dumpfile); for (formal = sym->formal; formal; formal = formal->next) { if (formal->sym != NULL) ! fprintf (dumpfile, " %s", formal->sym->name); else ! fputs (" [Alt Return]", dumpfile); } } if (sym->formal_ns) { show_indent (); ! fputs ("Formal namespace", dumpfile); ! show_namespace (sym->formal_ns); } ! fputc ('\n', dumpfile); } *************** show_uop (gfc_user_op *uop) *** 751,760 **** gfc_interface *intr; show_indent (); ! gfc_status ("%s:", uop->name); ! for (intr = uop->operator; intr; intr = intr->next) ! gfc_status (" %s", intr->sym->name); } --- 832,841 ---- gfc_interface *intr; show_indent (); ! fprintf (dumpfile, "%s:", uop->name); ! for (intr = uop->op; intr; intr = intr->next) ! fprintf (dumpfile, " %s", intr->sym->name); } *************** show_common (gfc_symtree *st) *** 790,806 **** gfc_symbol *s; show_indent (); ! gfc_status ("common: /%s/ ", st->name); s = st->n.common->head; while (s) { ! gfc_status ("%s", s->name); s = s->common_next; if (s) ! gfc_status (", "); } ! gfc_status_char ('\n'); } --- 871,887 ---- gfc_symbol *s; show_indent (); ! fprintf (dumpfile, "common: /%s/ ", st->name); s = st->n.common->head; while (s) { ! fprintf (dumpfile, "%s", s->name); s = s->common_next; if (s) ! fputs (", ", dumpfile); } ! fputc ('\n', dumpfile); } *************** static void *** 810,853 **** show_symtree (gfc_symtree *st) { show_indent (); ! gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous); if (st->n.sym->ns != gfc_current_ns) ! gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name); else ! gfc_show_symbol (st->n.sym); } /******************* Show gfc_code structures **************/ - - static void gfc_show_code_node (int, gfc_code *); - /* Show a list of code structures. Mutually recursive with ! gfc_show_code_node(). */ ! void ! gfc_show_code (int level, gfc_code *c) { for (; c; c = c->next) ! gfc_show_code_node (level, c); } ! void ! gfc_show_namelist (gfc_namelist *n) { for (; n->next; n = n->next) ! gfc_status ("%s,", n->sym->name); ! gfc_status ("%s", n->sym->name); } /* Show a single OpenMP directive node and everything underneath it if necessary. */ static void ! gfc_show_omp_node (int level, gfc_code *c) { gfc_omp_clauses *omp_clauses = NULL; const char *name = NULL; --- 891,931 ---- show_symtree (gfc_symtree *st) { show_indent (); ! fprintf (dumpfile, "symtree: %s Ambig %d", st->name, st->ambiguous); if (st->n.sym->ns != gfc_current_ns) ! fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name); else ! show_symbol (st->n.sym); } /******************* Show gfc_code structures **************/ /* Show a list of code structures. Mutually recursive with ! show_code_node(). */ ! static void ! show_code (int level, gfc_code *c) { for (; c; c = c->next) ! show_code_node (level, c); } ! static void ! show_namelist (gfc_namelist *n) { for (; n->next; n = n->next) ! fprintf (dumpfile, "%s,", n->sym->name); ! fprintf (dumpfile, "%s", n->sym->name); } /* Show a single OpenMP directive node and everything underneath it if necessary. */ static void ! show_omp_node (int level, gfc_code *c) { gfc_omp_clauses *omp_clauses = NULL; const char *name = NULL; *************** gfc_show_omp_node (int level, gfc_code * *** 867,877 **** case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break; case EXEC_OMP_SECTIONS: name = "SECTIONS"; break; case EXEC_OMP_SINGLE: name = "SINGLE"; break; case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break; default: gcc_unreachable (); } ! gfc_status ("!$OMP %s", name); switch (c->op) { case EXEC_OMP_DO: --- 945,957 ---- case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break; case EXEC_OMP_SECTIONS: name = "SECTIONS"; break; case EXEC_OMP_SINGLE: name = "SINGLE"; break; + case EXEC_OMP_TASK: name = "TASK"; break; + case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break; case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break; default: gcc_unreachable (); } ! fprintf (dumpfile, "!$OMP %s", name); switch (c->op) { case EXEC_OMP_DO: *************** gfc_show_omp_node (int level, gfc_code * *** 882,902 **** case EXEC_OMP_SINGLE: case EXEC_OMP_WORKSHARE: case EXEC_OMP_PARALLEL_WORKSHARE: omp_clauses = c->ext.omp_clauses; break; case EXEC_OMP_CRITICAL: if (c->ext.omp_name) ! gfc_status (" (%s)", c->ext.omp_name); break; case EXEC_OMP_FLUSH: if (c->ext.omp_namelist) { ! gfc_status (" ("); ! gfc_show_namelist (c->ext.omp_namelist); ! gfc_status_char (')'); } return; case EXEC_OMP_BARRIER: return; default: break; --- 962,984 ---- case EXEC_OMP_SINGLE: case EXEC_OMP_WORKSHARE: case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_TASK: omp_clauses = c->ext.omp_clauses; break; case EXEC_OMP_CRITICAL: if (c->ext.omp_name) ! fprintf (dumpfile, " (%s)", c->ext.omp_name); break; case EXEC_OMP_FLUSH: if (c->ext.omp_namelist) { ! fputs (" (", dumpfile); ! show_namelist (c->ext.omp_namelist); ! fputc (')', dumpfile); } return; case EXEC_OMP_BARRIER: + case EXEC_OMP_TASKWAIT: return; default: break; *************** gfc_show_omp_node (int level, gfc_code * *** 907,921 **** if (omp_clauses->if_expr) { ! gfc_status (" IF("); ! gfc_show_expr (omp_clauses->if_expr); ! gfc_status_char (')'); } if (omp_clauses->num_threads) { ! gfc_status (" NUM_THREADS("); ! gfc_show_expr (omp_clauses->num_threads); ! gfc_status_char (')'); } if (omp_clauses->sched_kind != OMP_SCHED_NONE) { --- 989,1003 ---- if (omp_clauses->if_expr) { ! fputs (" IF(", dumpfile); ! show_expr (omp_clauses->if_expr); ! fputc (')', dumpfile); } if (omp_clauses->num_threads) { ! fputs (" NUM_THREADS(", dumpfile); ! show_expr (omp_clauses->num_threads); ! fputc (')', dumpfile); } if (omp_clauses->sched_kind != OMP_SCHED_NONE) { *************** gfc_show_omp_node (int level, gfc_code * *** 926,941 **** case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break; case OMP_SCHED_GUIDED: type = "GUIDED"; break; case OMP_SCHED_RUNTIME: type = "RUNTIME"; break; default: gcc_unreachable (); } ! gfc_status (" SCHEDULE (%s", type); if (omp_clauses->chunk_size) { ! gfc_status_char (','); ! gfc_show_expr (omp_clauses->chunk_size); } ! gfc_status_char (')'); } if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN) { --- 1008,1024 ---- case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break; case OMP_SCHED_GUIDED: type = "GUIDED"; break; case OMP_SCHED_RUNTIME: type = "RUNTIME"; break; + case OMP_SCHED_AUTO: type = "AUTO"; break; default: gcc_unreachable (); } ! fprintf (dumpfile, " SCHEDULE (%s", type); if (omp_clauses->chunk_size) { ! fputc (',', dumpfile); ! show_expr (omp_clauses->chunk_size); } ! fputc (')', dumpfile); } if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN) { *************** gfc_show_omp_node (int level, gfc_code * *** 945,958 **** case OMP_DEFAULT_NONE: type = "NONE"; break; case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break; case OMP_DEFAULT_SHARED: type = "SHARED"; break; ! case OMP_SCHED_RUNTIME: type = "RUNTIME"; break; default: gcc_unreachable (); } ! gfc_status (" DEFAULT(%s)", type); } if (omp_clauses->ordered) ! gfc_status (" ORDERED"); for (list_type = 0; list_type < OMP_LIST_NUM; list_type++) if (omp_clauses->lists[list_type] != NULL && list_type != OMP_LIST_COPYPRIVATE) --- 1028,1045 ---- case OMP_DEFAULT_NONE: type = "NONE"; break; case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break; case OMP_DEFAULT_SHARED: type = "SHARED"; break; ! case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break; default: gcc_unreachable (); } ! fprintf (dumpfile, " DEFAULT(%s)", type); } if (omp_clauses->ordered) ! fputs (" ORDERED", dumpfile); ! if (omp_clauses->untied) ! fputs (" UNTIED", dumpfile); ! if (omp_clauses->collapse) ! fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse); for (list_type = 0; list_type < OMP_LIST_NUM; list_type++) if (omp_clauses->lists[list_type] != NULL && list_type != OMP_LIST_COPYPRIVATE) *************** gfc_show_omp_node (int level, gfc_code * *** 977,983 **** default: gcc_unreachable (); } ! gfc_status (" REDUCTION(%s:", type); } else { --- 1064,1070 ---- default: gcc_unreachable (); } ! fprintf (dumpfile, " REDUCTION(%s:", type); } else { *************** gfc_show_omp_node (int level, gfc_code * *** 991,1042 **** default: gcc_unreachable (); } ! gfc_status (" %s(", type); } ! gfc_show_namelist (omp_clauses->lists[list_type]); ! gfc_status_char (')'); } } ! gfc_status_char ('\n'); if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS) { gfc_code *d = c->block; while (d != NULL) { ! gfc_show_code (level + 1, d->next); if (d->block == NULL) break; code_indent (level, 0); ! gfc_status ("!$OMP SECTION\n"); d = d->block; } } else ! gfc_show_code (level + 1, c->block->next); if (c->op == EXEC_OMP_ATOMIC) return; code_indent (level, 0); ! gfc_status ("!$OMP END %s", name); if (omp_clauses != NULL) { if (omp_clauses->lists[OMP_LIST_COPYPRIVATE]) { ! gfc_status (" COPYPRIVATE("); ! gfc_show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]); ! gfc_status_char (')'); } else if (omp_clauses->nowait) ! gfc_status (" NOWAIT"); } else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name) ! gfc_status (" (%s)", c->ext.omp_name); } /* Show a single code node and everything underneath it if necessary. */ static void ! gfc_show_code_node (int level, gfc_code *c) { gfc_forall_iterator *fa; gfc_open *open; --- 1078,1129 ---- default: gcc_unreachable (); } ! fprintf (dumpfile, " %s(", type); } ! show_namelist (omp_clauses->lists[list_type]); ! fputc (')', dumpfile); } } ! fputc ('\n', dumpfile); if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS) { gfc_code *d = c->block; while (d != NULL) { ! show_code (level + 1, d->next); if (d->block == NULL) break; code_indent (level, 0); ! fputs ("!$OMP SECTION\n", dumpfile); d = d->block; } } else ! show_code (level + 1, c->block->next); if (c->op == EXEC_OMP_ATOMIC) return; code_indent (level, 0); ! fprintf (dumpfile, "!$OMP END %s", name); if (omp_clauses != NULL) { if (omp_clauses->lists[OMP_LIST_COPYPRIVATE]) { ! fputs (" COPYPRIVATE(", dumpfile); ! show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]); ! fputc (')', dumpfile); } else if (omp_clauses->nowait) ! fputs (" NOWAIT", dumpfile); } else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name) ! fprintf (dumpfile, " (%s)", c->ext.omp_name); } /* Show a single code node and everything underneath it if necessary. */ static void ! show_code_node (int level, gfc_code *c) { gfc_forall_iterator *fa; gfc_open *open; *************** gfc_show_code_node (int level, gfc_code *** 1053,1108 **** switch (c->op) { case EXEC_NOP: ! gfc_status ("NOP"); break; case EXEC_CONTINUE: ! gfc_status ("CONTINUE"); break; case EXEC_ENTRY: ! 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_status_char (' '); ! gfc_show_expr (c->expr2); break; case EXEC_LABEL_ASSIGN: ! gfc_status ("LABEL ASSIGN "); ! gfc_show_expr (c->expr); ! gfc_status (" %d", c->label->value); break; case EXEC_POINTER_ASSIGN: ! gfc_status ("POINTER ASSIGN "); ! gfc_show_expr (c->expr); ! gfc_status_char (' '); ! gfc_show_expr (c->expr2); break; case EXEC_GOTO: ! gfc_status ("GOTO "); if (c->label) ! gfc_status ("%d", c->label->value); else { ! gfc_show_expr (c->expr); d = c->block; if (d != NULL) { ! gfc_status (", ("); for (; d; d = d ->block) { code_indent (level, d->label); if (d->block != NULL) ! gfc_status_char (','); else ! gfc_status_char (')'); } } } --- 1140,1195 ---- switch (c->op) { case EXEC_NOP: ! fputs ("NOP", dumpfile); break; case EXEC_CONTINUE: ! fputs ("CONTINUE", dumpfile); break; case EXEC_ENTRY: ! fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name); break; case EXEC_INIT_ASSIGN: case EXEC_ASSIGN: ! fputs ("ASSIGN ", dumpfile); ! show_expr (c->expr); ! fputc (' ', dumpfile); ! show_expr (c->expr2); break; case EXEC_LABEL_ASSIGN: ! fputs ("LABEL ASSIGN ", dumpfile); ! show_expr (c->expr); ! fprintf (dumpfile, " %d", c->label->value); break; case EXEC_POINTER_ASSIGN: ! fputs ("POINTER ASSIGN ", dumpfile); ! show_expr (c->expr); ! fputc (' ', dumpfile); ! show_expr (c->expr2); break; case EXEC_GOTO: ! fputs ("GOTO ", dumpfile); if (c->label) ! fprintf (dumpfile, "%d", c->label->value); else { ! show_expr (c->expr); d = c->block; if (d != NULL) { ! fputs (", (", dumpfile); for (; d; d = d ->block) { code_indent (level, d->label); if (d->block != NULL) ! fputc (',', dumpfile); else ! fputc (')', dumpfile); } } } *************** gfc_show_code_node (int level, gfc_code *** 1111,1164 **** case EXEC_CALL: case EXEC_ASSIGN_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; case EXEC_RETURN: ! gfc_status ("RETURN "); if (c->expr) ! gfc_show_expr (c->expr); break; case EXEC_PAUSE: ! gfc_status ("PAUSE "); if (c->expr != NULL) ! gfc_show_expr (c->expr); else ! gfc_status ("%d", c->ext.stop_code); break; case EXEC_STOP: ! gfc_status ("STOP "); if (c->expr != NULL) ! gfc_show_expr (c->expr); else ! gfc_status ("%d", c->ext.stop_code); break; case EXEC_ARITHMETIC_IF: ! gfc_status ("IF "); ! gfc_show_expr (c->expr); ! gfc_status (" %d, %d, %d", c->label->value, c->label2->value, c->label3->value); break; case EXEC_IF: d = c->block; ! gfc_status ("IF "); ! gfc_show_expr (d->expr); ! gfc_status_char ('\n'); ! gfc_show_code (level + 1, d->next); d = d->block; for (; d; d = d->block) --- 1198,1256 ---- case EXEC_CALL: case EXEC_ASSIGN_CALL: if (c->resolved_sym) ! fprintf (dumpfile, "CALL %s ", c->resolved_sym->name); else if (c->symtree) ! fprintf (dumpfile, "CALL %s ", c->symtree->name); else ! fputs ("CALL ?? ", dumpfile); ! show_actual_arglist (c->ext.actual); ! break; ! ! case EXEC_COMPCALL: ! fputs ("CALL ", dumpfile); ! show_compcall (c->expr); break; case EXEC_RETURN: ! fputs ("RETURN ", dumpfile); if (c->expr) ! show_expr (c->expr); break; case EXEC_PAUSE: ! fputs ("PAUSE ", dumpfile); if (c->expr != NULL) ! show_expr (c->expr); else ! fprintf (dumpfile, "%d", c->ext.stop_code); break; case EXEC_STOP: ! fputs ("STOP ", dumpfile); if (c->expr != NULL) ! show_expr (c->expr); else ! fprintf (dumpfile, "%d", c->ext.stop_code); break; case EXEC_ARITHMETIC_IF: ! fputs ("IF ", dumpfile); ! show_expr (c->expr); ! fprintf (dumpfile, " %d, %d, %d", c->label->value, c->label2->value, c->label3->value); break; case EXEC_IF: d = c->block; ! fputs ("IF ", dumpfile); ! show_expr (d->expr); ! fputc ('\n', dumpfile); ! show_code (level + 1, d->next); d = d->block; for (; d; d = d->block) *************** gfc_show_code_node (int level, gfc_code *** 1166,1705 **** code_indent (level, 0); if (d->expr == NULL) ! gfc_status ("ELSE\n"); else { ! gfc_status ("ELSE IF "); ! gfc_show_expr (d->expr); ! gfc_status_char ('\n'); } ! gfc_show_code (level + 1, d->next); } code_indent (level, c->label); ! gfc_status ("ENDIF"); break; case EXEC_SELECT: d = c->block; ! gfc_status ("SELECT CASE "); ! gfc_show_expr (c->expr); ! gfc_status_char ('\n'); for (; d; d = d->block) { code_indent (level, 0); ! gfc_status ("CASE "); for (cp = d->ext.case_list; cp; cp = cp->next) { ! gfc_status_char ('('); ! gfc_show_expr (cp->low); ! gfc_status_char (' '); ! gfc_show_expr (cp->high); ! gfc_status_char (')'); ! gfc_status_char (' '); } ! gfc_status_char ('\n'); ! gfc_show_code (level + 1, d->next); } code_indent (level, c->label); ! gfc_status ("END SELECT"); break; case EXEC_WHERE: ! gfc_status ("WHERE "); d = c->block; ! gfc_show_expr (d->expr); ! gfc_status_char ('\n'); ! gfc_show_code (level + 1, d->next); for (d = d->block; d; d = d->block) { code_indent (level, 0); ! gfc_status ("ELSE WHERE "); ! gfc_show_expr (d->expr); ! gfc_status_char ('\n'); ! gfc_show_code (level + 1, d->next); } code_indent (level, 0); ! gfc_status ("END WHERE"); break; case EXEC_FORALL: ! gfc_status ("FORALL "); for (fa = c->ext.forall_iterator; fa; fa = fa->next) { ! gfc_show_expr (fa->var); ! gfc_status_char (' '); ! gfc_show_expr (fa->start); ! gfc_status_char (':'); ! gfc_show_expr (fa->end); ! gfc_status_char (':'); ! gfc_show_expr (fa->stride); if (fa->next != NULL) ! gfc_status_char (','); } if (c->expr != NULL) { ! gfc_status_char (','); ! gfc_show_expr (c->expr); } ! gfc_status_char ('\n'); ! gfc_show_code (level + 1, c->block->next); code_indent (level, 0); ! gfc_status ("END FORALL"); break; case EXEC_DO: ! gfc_status ("DO "); ! gfc_show_expr (c->ext.iterator->var); ! gfc_status_char ('='); ! gfc_show_expr (c->ext.iterator->start); ! gfc_status_char (' '); ! gfc_show_expr (c->ext.iterator->end); ! gfc_status_char (' '); ! gfc_show_expr (c->ext.iterator->step); ! gfc_status_char ('\n'); ! gfc_show_code (level + 1, c->block->next); code_indent (level, 0); ! gfc_status ("END DO"); break; case EXEC_DO_WHILE: ! gfc_status ("DO WHILE "); ! gfc_show_expr (c->expr); ! gfc_status_char ('\n'); ! gfc_show_code (level + 1, c->block->next); code_indent (level, c->label); ! gfc_status ("END DO"); break; case EXEC_CYCLE: ! gfc_status ("CYCLE"); if (c->symtree) ! gfc_status (" %s", c->symtree->n.sym->name); break; case EXEC_EXIT: ! gfc_status ("EXIT"); if (c->symtree) ! gfc_status (" %s", c->symtree->n.sym->name); break; case EXEC_ALLOCATE: ! gfc_status ("ALLOCATE "); if (c->expr) { ! gfc_status (" STAT="); ! gfc_show_expr (c->expr); } for (a = c->ext.alloc_list; a; a = a->next) { ! gfc_status_char (' '); ! gfc_show_expr (a->expr); } break; case EXEC_DEALLOCATE: ! gfc_status ("DEALLOCATE "); if (c->expr) { ! gfc_status (" STAT="); ! gfc_show_expr (c->expr); } for (a = c->ext.alloc_list; a; a = a->next) { ! gfc_status_char (' '); ! gfc_show_expr (a->expr); } break; case EXEC_OPEN: ! gfc_status ("OPEN"); open = c->ext.open; if (open->unit) { ! gfc_status (" UNIT="); ! gfc_show_expr (open->unit); } if (open->iomsg) { ! gfc_status (" IOMSG="); ! gfc_show_expr (open->iomsg); } if (open->iostat) { ! gfc_status (" IOSTAT="); ! gfc_show_expr (open->iostat); } if (open->file) { ! gfc_status (" FILE="); ! gfc_show_expr (open->file); } if (open->status) { ! gfc_status (" STATUS="); ! gfc_show_expr (open->status); } if (open->access) { ! gfc_status (" ACCESS="); ! gfc_show_expr (open->access); } if (open->form) { ! gfc_status (" FORM="); ! gfc_show_expr (open->form); } if (open->recl) { ! gfc_status (" RECL="); ! gfc_show_expr (open->recl); } if (open->blank) { ! gfc_status (" BLANK="); ! gfc_show_expr (open->blank); } if (open->position) { ! gfc_status (" POSITION="); ! gfc_show_expr (open->position); } if (open->action) { ! gfc_status (" ACTION="); ! gfc_show_expr (open->action); } if (open->delim) { ! gfc_status (" DELIM="); ! gfc_show_expr (open->delim); } if (open->pad) { ! gfc_status (" PAD="); ! gfc_show_expr (open->pad); } if (open->convert) { ! gfc_status (" CONVERT="); ! gfc_show_expr (open->convert); } if (open->err != NULL) ! gfc_status (" ERR=%d", open->err->value); break; case EXEC_CLOSE: ! gfc_status ("CLOSE"); close = c->ext.close; if (close->unit) { ! gfc_status (" UNIT="); ! gfc_show_expr (close->unit); } if (close->iomsg) { ! gfc_status (" IOMSG="); ! gfc_show_expr (close->iomsg); } if (close->iostat) { ! gfc_status (" IOSTAT="); ! gfc_show_expr (close->iostat); } if (close->status) { ! gfc_status (" STATUS="); ! gfc_show_expr (close->status); } if (close->err != NULL) ! gfc_status (" ERR=%d", close->err->value); break; case EXEC_BACKSPACE: ! gfc_status ("BACKSPACE"); goto show_filepos; case EXEC_ENDFILE: ! gfc_status ("ENDFILE"); goto show_filepos; case EXEC_REWIND: ! gfc_status ("REWIND"); goto show_filepos; case EXEC_FLUSH: ! gfc_status ("FLUSH"); show_filepos: fp = c->ext.filepos; if (fp->unit) { ! gfc_status (" UNIT="); ! gfc_show_expr (fp->unit); } if (fp->iomsg) { ! gfc_status (" IOMSG="); ! gfc_show_expr (fp->iomsg); } if (fp->iostat) { ! gfc_status (" IOSTAT="); ! gfc_show_expr (fp->iostat); } if (fp->err != NULL) ! gfc_status (" ERR=%d", fp->err->value); break; case EXEC_INQUIRE: ! gfc_status ("INQUIRE"); i = c->ext.inquire; if (i->unit) { ! gfc_status (" UNIT="); ! gfc_show_expr (i->unit); } if (i->file) { ! gfc_status (" FILE="); ! gfc_show_expr (i->file); } if (i->iomsg) { ! gfc_status (" IOMSG="); ! gfc_show_expr (i->iomsg); } if (i->iostat) { ! gfc_status (" IOSTAT="); ! gfc_show_expr (i->iostat); } if (i->exist) { ! gfc_status (" EXIST="); ! gfc_show_expr (i->exist); } if (i->opened) { ! gfc_status (" OPENED="); ! gfc_show_expr (i->opened); } if (i->number) { ! gfc_status (" NUMBER="); ! gfc_show_expr (i->number); } if (i->named) { ! gfc_status (" NAMED="); ! gfc_show_expr (i->named); } if (i->name) { ! gfc_status (" NAME="); ! gfc_show_expr (i->name); } if (i->access) { ! gfc_status (" ACCESS="); ! gfc_show_expr (i->access); } if (i->sequential) { ! gfc_status (" SEQUENTIAL="); ! gfc_show_expr (i->sequential); } if (i->direct) { ! gfc_status (" DIRECT="); ! gfc_show_expr (i->direct); } if (i->form) { ! gfc_status (" FORM="); ! gfc_show_expr (i->form); } if (i->formatted) { ! gfc_status (" FORMATTED"); ! gfc_show_expr (i->formatted); } if (i->unformatted) { ! gfc_status (" UNFORMATTED="); ! gfc_show_expr (i->unformatted); } if (i->recl) { ! gfc_status (" RECL="); ! gfc_show_expr (i->recl); } if (i->nextrec) { ! gfc_status (" NEXTREC="); ! gfc_show_expr (i->nextrec); } if (i->blank) { ! gfc_status (" BLANK="); ! gfc_show_expr (i->blank); } if (i->position) { ! gfc_status (" POSITION="); ! gfc_show_expr (i->position); } if (i->action) { ! gfc_status (" ACTION="); ! gfc_show_expr (i->action); } if (i->read) { ! gfc_status (" READ="); ! gfc_show_expr (i->read); } if (i->write) { ! gfc_status (" WRITE="); ! gfc_show_expr (i->write); } if (i->readwrite) { ! gfc_status (" READWRITE="); ! gfc_show_expr (i->readwrite); } if (i->delim) { ! gfc_status (" DELIM="); ! gfc_show_expr (i->delim); } if (i->pad) { ! gfc_status (" PAD="); ! gfc_show_expr (i->pad); } if (i->convert) { ! gfc_status (" CONVERT="); ! gfc_show_expr (i->convert); } if (i->err != NULL) ! gfc_status (" ERR=%d", i->err->value); break; case EXEC_IOLENGTH: ! gfc_status ("IOLENGTH "); ! gfc_show_expr (c->expr); goto show_dt_code; break; case EXEC_READ: ! gfc_status ("READ"); goto show_dt; case EXEC_WRITE: ! gfc_status ("WRITE"); show_dt: dt = c->ext.dt; if (dt->io_unit) { ! gfc_status (" UNIT="); ! gfc_show_expr (dt->io_unit); } if (dt->format_expr) { ! gfc_status (" FMT="); ! gfc_show_expr (dt->format_expr); } if (dt->format_label != NULL) ! gfc_status (" FMT=%d", dt->format_label->value); if (dt->namelist) ! gfc_status (" NML=%s", dt->namelist->name); if (dt->iomsg) { ! gfc_status (" IOMSG="); ! gfc_show_expr (dt->iomsg); } if (dt->iostat) { ! gfc_status (" IOSTAT="); ! gfc_show_expr (dt->iostat); } if (dt->size) { ! gfc_status (" SIZE="); ! gfc_show_expr (dt->size); } if (dt->rec) { ! gfc_status (" REC="); ! gfc_show_expr (dt->rec); } if (dt->advance) { ! gfc_status (" ADVANCE="); ! gfc_show_expr (dt->advance); } show_dt_code: ! gfc_status_char ('\n'); for (c = c->block->next; c; c = c->next) ! gfc_show_code_node (level + (c->next != NULL), c); return; case EXEC_TRANSFER: ! gfc_status ("TRANSFER "); ! gfc_show_expr (c->expr); break; case EXEC_DT_END: ! gfc_status ("DT_END"); dt = c->ext.dt; if (dt->err != NULL) ! gfc_status (" ERR=%d", dt->err->value); if (dt->end != NULL) ! gfc_status (" END=%d", dt->end->value); if (dt->eor != NULL) ! gfc_status (" EOR=%d", dt->eor->value); break; case EXEC_OMP_ATOMIC: --- 1258,1907 ---- code_indent (level, 0); if (d->expr == NULL) ! fputs ("ELSE\n", dumpfile); else { ! fputs ("ELSE IF ", dumpfile); ! show_expr (d->expr); ! fputc ('\n', dumpfile); } ! show_code (level + 1, d->next); } code_indent (level, c->label); ! fputs ("ENDIF", dumpfile); break; case EXEC_SELECT: d = c->block; ! fputs ("SELECT CASE ", dumpfile); ! show_expr (c->expr); ! fputc ('\n', dumpfile); for (; d; d = d->block) { code_indent (level, 0); ! fputs ("CASE ", dumpfile); for (cp = d->ext.case_list; cp; cp = cp->next) { ! fputc ('(', dumpfile); ! show_expr (cp->low); ! fputc (' ', dumpfile); ! show_expr (cp->high); ! fputc (')', dumpfile); ! fputc (' ', dumpfile); } ! fputc ('\n', dumpfile); ! show_code (level + 1, d->next); } code_indent (level, c->label); ! fputs ("END SELECT", dumpfile); break; case EXEC_WHERE: ! fputs ("WHERE ", dumpfile); d = c->block; ! show_expr (d->expr); ! fputc ('\n', dumpfile); ! show_code (level + 1, d->next); for (d = d->block; d; d = d->block) { code_indent (level, 0); ! fputs ("ELSE WHERE ", dumpfile); ! show_expr (d->expr); ! fputc ('\n', dumpfile); ! show_code (level + 1, d->next); } code_indent (level, 0); ! fputs ("END WHERE", dumpfile); break; case EXEC_FORALL: ! fputs ("FORALL ", dumpfile); for (fa = c->ext.forall_iterator; fa; fa = fa->next) { ! show_expr (fa->var); ! fputc (' ', dumpfile); ! show_expr (fa->start); ! fputc (':', dumpfile); ! show_expr (fa->end); ! fputc (':', dumpfile); ! show_expr (fa->stride); if (fa->next != NULL) ! fputc (',', dumpfile); } if (c->expr != NULL) { ! fputc (',', dumpfile); ! show_expr (c->expr); } ! fputc ('\n', dumpfile); ! show_code (level + 1, c->block->next); code_indent (level, 0); ! fputs ("END FORALL", dumpfile); break; case EXEC_DO: ! fputs ("DO ", dumpfile); ! show_expr (c->ext.iterator->var); ! fputc ('=', dumpfile); ! show_expr (c->ext.iterator->start); ! fputc (' ', dumpfile); ! show_expr (c->ext.iterator->end); ! fputc (' ', dumpfile); ! show_expr (c->ext.iterator->step); ! fputc ('\n', dumpfile); ! show_code (level + 1, c->block->next); code_indent (level, 0); ! fputs ("END DO", dumpfile); break; case EXEC_DO_WHILE: ! fputs ("DO WHILE ", dumpfile); ! show_expr (c->expr); ! fputc ('\n', dumpfile); ! show_code (level + 1, c->block->next); code_indent (level, c->label); ! fputs ("END DO", dumpfile); break; case EXEC_CYCLE: ! fputs ("CYCLE", dumpfile); if (c->symtree) ! fprintf (dumpfile, " %s", c->symtree->n.sym->name); break; case EXEC_EXIT: ! fputs ("EXIT", dumpfile); if (c->symtree) ! fprintf (dumpfile, " %s", c->symtree->n.sym->name); break; case EXEC_ALLOCATE: ! fputs ("ALLOCATE ", dumpfile); if (c->expr) { ! fputs (" STAT=", dumpfile); ! show_expr (c->expr); } for (a = c->ext.alloc_list; a; a = a->next) { ! fputc (' ', dumpfile); ! show_expr (a->expr); } break; case EXEC_DEALLOCATE: ! fputs ("DEALLOCATE ", dumpfile); if (c->expr) { ! fputs (" STAT=", dumpfile); ! show_expr (c->expr); } for (a = c->ext.alloc_list; a; a = a->next) { ! fputc (' ', dumpfile); ! show_expr (a->expr); } break; case EXEC_OPEN: ! fputs ("OPEN", dumpfile); open = c->ext.open; if (open->unit) { ! fputs (" UNIT=", dumpfile); ! show_expr (open->unit); } if (open->iomsg) { ! fputs (" IOMSG=", dumpfile); ! show_expr (open->iomsg); } if (open->iostat) { ! fputs (" IOSTAT=", dumpfile); ! show_expr (open->iostat); } if (open->file) { ! fputs (" FILE=", dumpfile); ! show_expr (open->file); } if (open->status) { ! fputs (" STATUS=", dumpfile); ! show_expr (open->status); } if (open->access) { ! fputs (" ACCESS=", dumpfile); ! show_expr (open->access); } if (open->form) { ! fputs (" FORM=", dumpfile); ! show_expr (open->form); } if (open->recl) { ! fputs (" RECL=", dumpfile); ! show_expr (open->recl); } if (open->blank) { ! fputs (" BLANK=", dumpfile); ! show_expr (open->blank); } if (open->position) { ! fputs (" POSITION=", dumpfile); ! show_expr (open->position); } if (open->action) { ! fputs (" ACTION=", dumpfile); ! show_expr (open->action); } if (open->delim) { ! fputs (" DELIM=", dumpfile); ! show_expr (open->delim); } if (open->pad) { ! fputs (" PAD=", dumpfile); ! show_expr (open->pad); ! } ! if (open->decimal) ! { ! fputs (" DECIMAL=", dumpfile); ! show_expr (open->decimal); ! } ! if (open->encoding) ! { ! fputs (" ENCODING=", dumpfile); ! show_expr (open->encoding); ! } ! if (open->round) ! { ! fputs (" ROUND=", dumpfile); ! show_expr (open->round); ! } ! if (open->sign) ! { ! fputs (" SIGN=", dumpfile); ! show_expr (open->sign); } if (open->convert) { ! fputs (" CONVERT=", dumpfile); ! show_expr (open->convert); ! } ! if (open->asynchronous) ! { ! fputs (" ASYNCHRONOUS=", dumpfile); ! show_expr (open->asynchronous); } if (open->err != NULL) ! fprintf (dumpfile, " ERR=%d", open->err->value); break; case EXEC_CLOSE: ! fputs ("CLOSE", dumpfile); close = c->ext.close; if (close->unit) { ! fputs (" UNIT=", dumpfile); ! show_expr (close->unit); } if (close->iomsg) { ! fputs (" IOMSG=", dumpfile); ! show_expr (close->iomsg); } if (close->iostat) { ! fputs (" IOSTAT=", dumpfile); ! show_expr (close->iostat); } if (close->status) { ! fputs (" STATUS=", dumpfile); ! show_expr (close->status); } if (close->err != NULL) ! fprintf (dumpfile, " ERR=%d", close->err->value); break; case EXEC_BACKSPACE: ! fputs ("BACKSPACE", dumpfile); goto show_filepos; case EXEC_ENDFILE: ! fputs ("ENDFILE", dumpfile); goto show_filepos; case EXEC_REWIND: ! fputs ("REWIND", dumpfile); goto show_filepos; case EXEC_FLUSH: ! fputs ("FLUSH", dumpfile); show_filepos: fp = c->ext.filepos; if (fp->unit) { ! fputs (" UNIT=", dumpfile); ! show_expr (fp->unit); } if (fp->iomsg) { ! fputs (" IOMSG=", dumpfile); ! show_expr (fp->iomsg); } if (fp->iostat) { ! fputs (" IOSTAT=", dumpfile); ! show_expr (fp->iostat); } if (fp->err != NULL) ! fprintf (dumpfile, " ERR=%d", fp->err->value); break; case EXEC_INQUIRE: ! fputs ("INQUIRE", dumpfile); i = c->ext.inquire; if (i->unit) { ! fputs (" UNIT=", dumpfile); ! show_expr (i->unit); } if (i->file) { ! fputs (" FILE=", dumpfile); ! show_expr (i->file); } if (i->iomsg) { ! fputs (" IOMSG=", dumpfile); ! show_expr (i->iomsg); } if (i->iostat) { ! fputs (" IOSTAT=", dumpfile); ! show_expr (i->iostat); } if (i->exist) { ! fputs (" EXIST=", dumpfile); ! show_expr (i->exist); } if (i->opened) { ! fputs (" OPENED=", dumpfile); ! show_expr (i->opened); } if (i->number) { ! fputs (" NUMBER=", dumpfile); ! show_expr (i->number); } if (i->named) { ! fputs (" NAMED=", dumpfile); ! show_expr (i->named); } if (i->name) { ! fputs (" NAME=", dumpfile); ! show_expr (i->name); } if (i->access) { ! fputs (" ACCESS=", dumpfile); ! show_expr (i->access); } if (i->sequential) { ! fputs (" SEQUENTIAL=", dumpfile); ! show_expr (i->sequential); } if (i->direct) { ! fputs (" DIRECT=", dumpfile); ! show_expr (i->direct); } if (i->form) { ! fputs (" FORM=", dumpfile); ! show_expr (i->form); } if (i->formatted) { ! fputs (" FORMATTED", dumpfile); ! show_expr (i->formatted); } if (i->unformatted) { ! fputs (" UNFORMATTED=", dumpfile); ! show_expr (i->unformatted); } if (i->recl) { ! fputs (" RECL=", dumpfile); ! show_expr (i->recl); } if (i->nextrec) { ! fputs (" NEXTREC=", dumpfile); ! show_expr (i->nextrec); } if (i->blank) { ! fputs (" BLANK=", dumpfile); ! show_expr (i->blank); } if (i->position) { ! fputs (" POSITION=", dumpfile); ! show_expr (i->position); } if (i->action) { ! fputs (" ACTION=", dumpfile); ! show_expr (i->action); } if (i->read) { ! fputs (" READ=", dumpfile); ! show_expr (i->read); } if (i->write) { ! fputs (" WRITE=", dumpfile); ! show_expr (i->write); } if (i->readwrite) { ! fputs (" READWRITE=", dumpfile); ! show_expr (i->readwrite); } if (i->delim) { ! fputs (" DELIM=", dumpfile); ! show_expr (i->delim); } if (i->pad) { ! fputs (" PAD=", dumpfile); ! show_expr (i->pad); } if (i->convert) { ! fputs (" CONVERT=", dumpfile); ! show_expr (i->convert); ! } ! if (i->asynchronous) ! { ! fputs (" ASYNCHRONOUS=", dumpfile); ! show_expr (i->asynchronous); ! } ! if (i->decimal) ! { ! fputs (" DECIMAL=", dumpfile); ! show_expr (i->decimal); ! } ! if (i->encoding) ! { ! fputs (" ENCODING=", dumpfile); ! show_expr (i->encoding); ! } ! if (i->pending) ! { ! fputs (" PENDING=", dumpfile); ! show_expr (i->pending); ! } ! if (i->round) ! { ! fputs (" ROUND=", dumpfile); ! show_expr (i->round); ! } ! if (i->sign) ! { ! fputs (" SIGN=", dumpfile); ! show_expr (i->sign); ! } ! if (i->size) ! { ! fputs (" SIZE=", dumpfile); ! show_expr (i->size); ! } ! if (i->id) ! { ! fputs (" ID=", dumpfile); ! show_expr (i->id); } if (i->err != NULL) ! fprintf (dumpfile, " ERR=%d", i->err->value); break; case EXEC_IOLENGTH: ! fputs ("IOLENGTH ", dumpfile); ! show_expr (c->expr); goto show_dt_code; break; case EXEC_READ: ! fputs ("READ", dumpfile); goto show_dt; case EXEC_WRITE: ! fputs ("WRITE", dumpfile); show_dt: dt = c->ext.dt; if (dt->io_unit) { ! fputs (" UNIT=", dumpfile); ! show_expr (dt->io_unit); } if (dt->format_expr) { ! fputs (" FMT=", dumpfile); ! show_expr (dt->format_expr); } if (dt->format_label != NULL) ! fprintf (dumpfile, " FMT=%d", dt->format_label->value); if (dt->namelist) ! fprintf (dumpfile, " NML=%s", dt->namelist->name); if (dt->iomsg) { ! fputs (" IOMSG=", dumpfile); ! show_expr (dt->iomsg); } if (dt->iostat) { ! fputs (" IOSTAT=", dumpfile); ! show_expr (dt->iostat); } if (dt->size) { ! fputs (" SIZE=", dumpfile); ! show_expr (dt->size); } if (dt->rec) { ! fputs (" REC=", dumpfile); ! show_expr (dt->rec); } if (dt->advance) { ! fputs (" ADVANCE=", dumpfile); ! show_expr (dt->advance); ! } ! if (dt->id) ! { ! fputs (" ID=", dumpfile); ! show_expr (dt->id); ! } ! if (dt->pos) ! { ! fputs (" POS=", dumpfile); ! show_expr (dt->pos); ! } ! if (dt->asynchronous) ! { ! fputs (" ASYNCHRONOUS=", dumpfile); ! show_expr (dt->asynchronous); ! } ! if (dt->blank) ! { ! fputs (" BLANK=", dumpfile); ! show_expr (dt->blank); ! } ! if (dt->decimal) ! { ! fputs (" DECIMAL=", dumpfile); ! show_expr (dt->decimal); ! } ! if (dt->delim) ! { ! fputs (" DELIM=", dumpfile); ! show_expr (dt->delim); ! } ! if (dt->pad) ! { ! fputs (" PAD=", dumpfile); ! show_expr (dt->pad); ! } ! if (dt->round) ! { ! fputs (" ROUND=", dumpfile); ! show_expr (dt->round); ! } ! if (dt->sign) ! { ! fputs (" SIGN=", dumpfile); ! show_expr (dt->sign); } show_dt_code: ! fputc ('\n', dumpfile); for (c = c->block->next; c; c = c->next) ! show_code_node (level + (c->next != NULL), c); return; case EXEC_TRANSFER: ! fputs ("TRANSFER ", dumpfile); ! show_expr (c->expr); break; case EXEC_DT_END: ! fputs ("DT_END", dumpfile); dt = c->ext.dt; if (dt->err != NULL) ! fprintf (dumpfile, " ERR=%d", dt->err->value); if (dt->end != NULL) ! fprintf (dumpfile, " END=%d", dt->end->value); if (dt->eor != NULL) ! fprintf (dumpfile, " EOR=%d", dt->eor->value); break; case EXEC_OMP_ATOMIC: *************** gfc_show_code_node (int level, gfc_code *** 1715,1753 **** case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SINGLE: case EXEC_OMP_WORKSHARE: ! gfc_show_omp_node (level, c); break; default: ! gfc_internal_error ("gfc_show_code_node(): Bad statement code"); } ! gfc_status_char ('\n'); } /* Show an equivalence chain. */ ! void ! gfc_show_equiv (gfc_equiv *eq) { show_indent (); ! gfc_status ("Equivalence: "); while (eq) { ! gfc_show_expr (eq->expr); eq = eq->eq; if (eq) ! gfc_status (", "); } } ! /* Show a freakin' whole namespace. */ ! void ! gfc_show_namespace (gfc_namespace *ns) { gfc_interface *intr; gfc_namespace *save; --- 1917,1957 ---- case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SINGLE: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKWAIT: case EXEC_OMP_WORKSHARE: ! show_omp_node (level, c); break; default: ! gfc_internal_error ("show_code_node(): Bad statement code"); } ! fputc ('\n', dumpfile); } /* Show an equivalence chain. */ ! static void ! show_equiv (gfc_equiv *eq) { show_indent (); ! fputs ("Equivalence: ", dumpfile); while (eq) { ! show_expr (eq->expr); eq = eq->eq; if (eq) ! fputs (", ", dumpfile); } } ! /* Show a freakin' whole namespace. */ ! static void ! show_namespace (gfc_namespace *ns) { gfc_interface *intr; gfc_namespace *save; *************** gfc_show_namespace (gfc_namespace *ns) *** 1759,1765 **** show_level++; show_indent (); ! gfc_status ("Namespace:"); if (ns != NULL) { --- 1963,1969 ---- show_level++; show_indent (); ! fputs ("Namespace:", dumpfile); if (ns != NULL) { *************** gfc_show_namespace (gfc_namespace *ns) *** 1773,1790 **** i++; if (i > l) ! gfc_status(" %c-%c: ", l+'A', i+'A'); else ! gfc_status(" %c: ", l+'A'); ! gfc_show_typespec(&ns->default_type[l]); i++; } while (i < GFC_LETTERS); if (ns->proc_name != NULL) { show_indent (); ! gfc_status ("procedure name = %s", ns->proc_name->name); } gfc_current_ns = ns; --- 1977,1994 ---- i++; if (i > l) ! fprintf (dumpfile, " %c-%c: ", l+'A', i+'A'); else ! fprintf (dumpfile, " %c: ", l+'A'); ! show_typespec(&ns->default_type[l]); i++; } while (i < GFC_LETTERS); if (ns->proc_name != NULL) { show_indent (); ! fprintf (dumpfile, "procedure name = %s", ns->proc_name->name); } gfc_current_ns = ns; *************** gfc_show_namespace (gfc_namespace *ns) *** 1795,1835 **** for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++) { /* User operator interfaces */ ! intr = ns->operator[op]; if (intr == NULL) continue; show_indent (); ! gfc_status ("Operator interfaces for %s:", gfc_op2string (op)); for (; intr; intr = intr->next) ! gfc_status (" %s", intr->sym->name); } if (ns->uop_root != NULL) { show_indent (); ! gfc_status ("User operators:\n"); gfc_traverse_user_op (ns, show_uop); } } for (eq = ns->equiv; eq; eq = eq->next) ! gfc_show_equiv (eq); ! gfc_status_char ('\n'); ! gfc_status_char ('\n'); ! gfc_show_code (0, ns->code); for (ns = ns->contained; ns; ns = ns->sibling) { show_indent (); ! gfc_status ("CONTAINS\n"); ! gfc_show_namespace (ns); } show_level--; ! gfc_status_char ('\n'); gfc_current_ns = save; } --- 1999,2050 ---- for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++) { /* User operator interfaces */ ! intr = ns->op[op]; if (intr == NULL) continue; show_indent (); ! fprintf (dumpfile, "Operator interfaces for %s:", ! gfc_op2string (op)); for (; intr; intr = intr->next) ! fprintf (dumpfile, " %s", intr->sym->name); } if (ns->uop_root != NULL) { show_indent (); ! fputs ("User operators:\n", dumpfile); gfc_traverse_user_op (ns, show_uop); } } for (eq = ns->equiv; eq; eq = eq->next) ! show_equiv (eq); ! fputc ('\n', dumpfile); ! fputc ('\n', dumpfile); ! show_code (0, ns->code); for (ns = ns->contained; ns; ns = ns->sibling) { show_indent (); ! fputs ("CONTAINS\n", dumpfile); ! show_namespace (ns); } show_level--; ! fputc ('\n', dumpfile); gfc_current_ns = save; } + + + /* Main function for dumping a parse tree. */ + + void + gfc_dump_parse_tree (gfc_namespace *ns, FILE *file) + { + dumpfile = file; + show_namespace (ns); + } diff -Nrcpad gcc-4.3.3/gcc/fortran/error.c gcc-4.4.0/gcc/fortran/error.c *** gcc-4.3.3/gcc/fortran/error.c Sun Dec 21 15:45:52 2008 --- gcc-4.4.0/gcc/fortran/error.c Mon Dec 15 14:46:22 2008 *************** *** 1,5 **** /* Handle errors. ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught & Niels Kristian Bech Jensen --- 1,5 ---- /* Handle errors. ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Andy Vaught & Niels Kristian Bech Jensen *************** along with GCC; see the file COPYING3. *** 30,42 **** #include "flags.h" #include "gfortran.h" ! int gfc_suppress_error = 0; static int terminal_width, buffer_flag, errors, warnings; static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer; /* Per-file error initialization. */ void --- 30,62 ---- #include "flags.h" #include "gfortran.h" ! static int suppress_errors = 0; static int terminal_width, buffer_flag, errors, warnings; static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer; + /* Go one level deeper suppressing errors. */ + + void + gfc_push_suppress_errors (void) + { + gcc_assert (suppress_errors >= 0); + ++suppress_errors; + } + + + /* Leave one level of error suppressing. */ + + void + gfc_pop_suppress_errors (void) + { + gcc_assert (suppress_errors > 0); + --suppress_errors; + } + + /* Per-file error initialization. */ void *************** error_char (char c) *** 70,77 **** { cur_error_buffer->allocated = cur_error_buffer->allocated ? cur_error_buffer->allocated * 2 : 1000; ! cur_error_buffer->message = xrealloc (cur_error_buffer->message, ! cur_error_buffer->allocated); } cur_error_buffer->message[cur_error_buffer->index++] = c; } --- 90,97 ---- { cur_error_buffer->allocated = cur_error_buffer->allocated ? cur_error_buffer->allocated * 2 : 1000; ! cur_error_buffer->message = XRESIZEVEC (char, cur_error_buffer->message, ! cur_error_buffer->allocated); } cur_error_buffer->message[cur_error_buffer->index++] = c; } *************** error_char (char c) *** 87,93 **** if (index + 1 >= allocated) { allocated = allocated ? allocated * 2 : 1000; ! line = xrealloc (line, allocated); } line[index++] = c; if (c == '\n') --- 107,113 ---- if (index + 1 >= allocated) { allocated = allocated ? allocated * 2 : 1000; ! line = XRESIZEVEC (char, line, allocated); } line[index++] = c; if (c == '\n') *************** error_integer (long int i) *** 152,157 **** --- 172,246 ---- } + static void + print_wide_char_into_buffer (gfc_char_t c, char *buf) + { + static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6', + '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' }; + + if (gfc_wide_is_printable (c)) + { + buf[1] = '\0'; + buf[0] = (unsigned char) c; + } + else if (c < ((gfc_char_t) 1 << 8)) + { + buf[4] = '\0'; + buf[3] = xdigit[c & 0x0F]; + c = c >> 4; + buf[2] = xdigit[c & 0x0F]; + + buf[1] = 'x'; + buf[0] = '\\'; + } + else if (c < ((gfc_char_t) 1 << 16)) + { + buf[6] = '\0'; + buf[5] = xdigit[c & 0x0F]; + c = c >> 4; + buf[4] = xdigit[c & 0x0F]; + c = c >> 4; + buf[3] = xdigit[c & 0x0F]; + c = c >> 4; + buf[2] = xdigit[c & 0x0F]; + + buf[1] = 'u'; + buf[0] = '\\'; + } + else + { + buf[10] = '\0'; + buf[9] = xdigit[c & 0x0F]; + c = c >> 4; + buf[8] = xdigit[c & 0x0F]; + c = c >> 4; + buf[7] = xdigit[c & 0x0F]; + c = c >> 4; + buf[6] = xdigit[c & 0x0F]; + c = c >> 4; + buf[5] = xdigit[c & 0x0F]; + c = c >> 4; + buf[4] = xdigit[c & 0x0F]; + c = c >> 4; + buf[3] = xdigit[c & 0x0F]; + c = c >> 4; + buf[2] = xdigit[c & 0x0F]; + + buf[1] = 'U'; + buf[0] = '\\'; + } + } + + static char wide_char_print_buffer[11]; + + const char * + gfc_print_wide_char (gfc_char_t c) + { + print_wide_char_into_buffer (c, wide_char_print_buffer); + return wide_char_print_buffer; + } + + /* Show the file, where it was included, and the source line, give a locus. Calls error_printf() recursively, but the recursion is at most one level deep. */ *************** show_locus (locus *loc, int c1, int c2) *** 163,170 **** { gfc_linebuf *lb; gfc_file *f; ! char c, *p; ! int i, m, offset, cmax; /* TODO: Either limit the total length and number of included files displayed or add buffering of arbitrary number of characters in --- 252,259 ---- { gfc_linebuf *lb; gfc_file *f; ! gfc_char_t c, *p; ! int i, offset, cmax; /* TODO: Either limit the total length and number of included files displayed or add buffering of arbitrary number of characters in *************** show_locus (locus *loc, int c1, int c2) *** 182,192 **** error_string (f->filename); error_char (':'); - #ifdef USE_MAPPED_LOCATION error_integer (LOCATION_LINE (lb->location)); - #else - error_integer (lb->linenum); - #endif if ((c1 > 0) || (c2 > 0)) error_char ('.'); --- 271,277 ---- *************** show_locus (locus *loc, int c1, int c2) *** 242,275 **** to work correctly when nonprintable characters exist. A better solution should be found. */ ! p = lb->line + offset; ! i = strlen (p); if (i > terminal_width) i = terminal_width - 1; for (; i > 0; i--) { c = *p++; if (c == '\t') c = ' '; ! if (ISPRINT (c)) ! error_char (c); ! else ! { ! error_char ('\\'); ! error_char ('x'); ! ! m = ((c >> 4) & 0x0F) + '0'; ! if (m > '9') ! m += 'A' - '9' - 1; ! error_char (m); ! ! m = (c & 0x0F) + '0'; ! if (m > '9') ! m += 'A' - '9' - 1; ! error_char (m); ! } } error_char ('\n'); --- 327,347 ---- to work correctly when nonprintable characters exist. A better solution should be found. */ ! p = &(lb->line[offset]); ! i = gfc_wide_strlen (p); if (i > terminal_width) i = terminal_width - 1; for (; i > 0; i--) { + static char buffer[11]; + c = *p++; if (c == '\t') c = ' '; ! print_wide_char_into_buffer (c, buffer); ! error_string (buffer); } error_char ('\n'); *************** gfc_notification_std (int std) *** 694,700 **** standard does not contain the requested bits. Return FAILURE if an error is generated. */ ! try gfc_notify_std (int std, const char *nocmsgid, ...) { va_list argp; --- 766,772 ---- standard does not contain the requested bits. Return FAILURE if an error is generated. */ ! gfc_try gfc_notify_std (int std, const char *nocmsgid, ...) { va_list argp; *************** gfc_notify_std (int std, const char *noc *** 704,710 **** if ((gfc_option.allow_std & std) != 0 && !warning) return SUCCESS; ! if (gfc_suppress_error) return warning ? SUCCESS : FAILURE; cur_error_buffer = warning ? &warning_buffer : &error_buffer; --- 776,782 ---- if ((gfc_option.allow_std & std) != 0 && !warning) return SUCCESS; ! if (suppress_errors) return warning ? SUCCESS : FAILURE; cur_error_buffer = warning ? &warning_buffer : &error_buffer; *************** gfc_error (const char *nocmsgid, ...) *** 790,796 **** { va_list argp; ! if (gfc_suppress_error) return; error_buffer.flag = 1; --- 862,868 ---- { va_list argp; ! if (suppress_errors) return; error_buffer.flag = 1; *************** gfc_free_error (gfc_error_buf *err) *** 959,989 **** } - /* Debug wrapper for printf. */ - - void - gfc_status (const char *cmsgid, ...) - { - va_list argp; - - va_start (argp, cmsgid); - - vprintf (_(cmsgid), argp); - - va_end (argp); - } - - - /* Subroutine for outputting a single char so that we don't have to go - around creating a lot of 1-character strings. */ - - void - gfc_status_char (char c) - { - putchar (c); - } - - /* Report the number of warnings and errors that occurred to the caller. */ void --- 1031,1036 ---- diff -Nrcpad gcc-4.3.3/gcc/fortran/expr.c gcc-4.4.0/gcc/fortran/expr.c *** gcc-4.3.3/gcc/fortran/expr.c Thu Jan 1 17:42:00 2009 --- gcc-4.4.0/gcc/fortran/expr.c Fri Feb 20 15:20:38 2009 *************** *** 1,5 **** /* Routines for manipulation of expression nodes. ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught --- 1,5 ---- /* Routines for manipulation of expression nodes. ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. Contributed by Andy Vaught *************** gfc_get_expr (void) *** 33,39 **** { gfc_expr *e; ! e = gfc_getmem (sizeof (gfc_expr)); gfc_clear_ts (&e->ts); e->shape = NULL; e->ref = NULL; --- 33,39 ---- { gfc_expr *e; ! e = XCNEW (gfc_expr); gfc_clear_ts (&e->ts); e->shape = NULL; e->ref = NULL; *************** gfc_free_actual_arglist (gfc_actual_argl *** 65,88 **** gfc_actual_arglist * gfc_copy_actual_arglist (gfc_actual_arglist *p) { ! gfc_actual_arglist *head, *tail, *new; head = tail = NULL; for (; p; p = p->next) { ! new = gfc_get_actual_arglist (); ! *new = *p; ! new->expr = gfc_copy_expr (p->expr); ! new->next = NULL; if (head == NULL) ! head = new; else ! tail->next = new; ! tail = new; } return head; --- 65,88 ---- gfc_actual_arglist * gfc_copy_actual_arglist (gfc_actual_arglist *p) { ! gfc_actual_arglist *head, *tail, *new_arg; head = tail = NULL; for (; p; p = p->next) { ! new_arg = gfc_get_actual_arglist (); ! *new_arg = *p; ! new_arg->expr = gfc_copy_expr (p->expr); ! new_arg->next = NULL; if (head == NULL) ! head = new_arg; else ! tail->next = new_arg; ! tail = new_arg; } return head; *************** free_expr0 (gfc_expr *e) *** 164,172 **** break; } ! /* Free the representation, except in character constants where it ! is the same as value.character.string and thus already freed. */ ! if (e->representation.string && e->ts.type != BT_CHARACTER) gfc_free (e->representation.string); break; --- 164,171 ---- break; } ! /* Free the representation. */ ! if (e->representation.string) gfc_free (e->representation.string); break; *************** free_expr0 (gfc_expr *e) *** 182,187 **** --- 181,190 ---- gfc_free_actual_arglist (e->value.function.actual); break; + case EXPR_COMPCALL: + gfc_free_actual_arglist (e->value.compcall.actual); + break; + case EXPR_VARIABLE: break; *************** gfc_extract_int (gfc_expr *expr, int *re *** 269,276 **** /* Recursively copy a list of reference structures. */ ! static gfc_ref * ! copy_ref (gfc_ref *src) { gfc_array_ref *ar; gfc_ref *dest; --- 272,279 ---- /* Recursively copy a list of reference structures. */ ! gfc_ref * ! gfc_copy_ref (gfc_ref *src) { gfc_array_ref *ar; gfc_ref *dest; *************** copy_ref (gfc_ref *src) *** 300,306 **** break; } ! dest->next = copy_ref (src->next); return dest; } --- 303,309 ---- break; } ! dest->next = gfc_copy_ref (src->next); return dest; } *************** gfc_expr * *** 393,399 **** gfc_copy_expr (gfc_expr *p) { gfc_expr *q; ! char *s; if (p == NULL) return NULL; --- 396,403 ---- gfc_copy_expr (gfc_expr *p) { gfc_expr *q; ! gfc_char_t *s; ! char *c; if (p == NULL) return NULL; *************** gfc_copy_expr (gfc_expr *p) *** 404,423 **** switch (q->expr_type) { case EXPR_SUBSTRING: ! s = gfc_getmem (p->value.character.length + 1); q->value.character.string = s; ! ! memcpy (s, p->value.character.string, p->value.character.length + 1); break; case EXPR_CONSTANT: /* Copy target representation, if it exists. */ if (p->representation.string) { ! s = gfc_getmem (p->representation.length + 1); ! q->representation.string = s; ! ! memcpy (s, p->representation.string, p->representation.length + 1); } /* Copy the values of any pointer components of p->value. */ --- 408,426 ---- switch (q->expr_type) { case EXPR_SUBSTRING: ! s = gfc_get_wide_string (p->value.character.length + 1); q->value.character.string = s; ! memcpy (s, p->value.character.string, ! (p->value.character.length + 1) * sizeof (gfc_char_t)); break; case EXPR_CONSTANT: /* Copy target representation, if it exists. */ if (p->representation.string) { ! c = XCNEWVEC (char, p->representation.length + 1); ! q->representation.string = c; ! memcpy (c, p->representation.string, (p->representation.length + 1)); } /* Copy the values of any pointer components of p->value. */ *************** gfc_copy_expr (gfc_expr *p) *** 443,452 **** case BT_CHARACTER: if (p->representation.string) ! q->value.character.string = q->representation.string; else { ! s = gfc_getmem (p->value.character.length + 1); q->value.character.string = s; /* This is the case for the C_NULL_CHAR named constant. */ --- 446,456 ---- case BT_CHARACTER: if (p->representation.string) ! q->value.character.string ! = gfc_char_to_widechar (q->representation.string); else { ! s = gfc_get_wide_string (p->value.character.length + 1); q->value.character.string = s; /* This is the case for the C_NULL_CHAR named constant. */ *************** gfc_copy_expr (gfc_expr *p) *** 460,466 **** } else memcpy (s, p->value.character.string, ! p->value.character.length + 1); } break; --- 464,470 ---- } else memcpy (s, p->value.character.string, ! (p->value.character.length + 1) * sizeof (gfc_char_t)); } break; *************** gfc_copy_expr (gfc_expr *p) *** 480,486 **** break; case EXPR_OP: ! switch (q->value.op.operator) { case INTRINSIC_NOT: case INTRINSIC_PARENTHESES: --- 484,490 ---- break; case EXPR_OP: ! switch (q->value.op.op) { case INTRINSIC_NOT: case INTRINSIC_PARENTHESES: *************** gfc_copy_expr (gfc_expr *p) *** 502,507 **** --- 506,517 ---- gfc_copy_actual_arglist (p->value.function.actual); break; + case EXPR_COMPCALL: + q->value.compcall.actual = + gfc_copy_actual_arglist (p->value.compcall.actual); + q->value.compcall.tbp = p->value.compcall.tbp; + break; + case EXPR_STRUCTURE: case EXPR_ARRAY: q->value.constructor = gfc_copy_constructor (p->value.constructor); *************** gfc_copy_expr (gfc_expr *p) *** 514,520 **** q->shape = gfc_copy_shape (p->shape, p->rank); ! q->ref = copy_ref (p->ref); return q; } --- 524,530 ---- q->shape = gfc_copy_shape (p->shape, p->rank); ! q->ref = gfc_copy_ref (p->ref); return q; } *************** gfc_type_convert_binary (gfc_expr *e) *** 659,665 **** e->ts = op1->ts; /* Special case for ** operator. */ ! if (e->value.op.operator == INTRINSIC_POWER) goto done; gfc_convert_type (e->value.op.op2, &e->ts, 2); --- 669,675 ---- e->ts = op1->ts; /* Special case for ** operator. */ ! if (e->value.op.op == INTRINSIC_POWER) goto done; gfc_convert_type (e->value.op.op2, &e->ts, 2); *************** is_subref_array (gfc_expr * e) *** 824,841 **** /* Try to collapse intrinsic expressions. */ ! static try simplify_intrinsic_op (gfc_expr *p, int type) { gfc_intrinsic_op op; gfc_expr *op1, *op2, *result; ! if (p->value.op.operator == INTRINSIC_USER) return SUCCESS; op1 = p->value.op.op1; op2 = p->value.op.op2; ! op = p->value.op.operator; if (gfc_simplify_expr (op1, type) == FAILURE) return FAILURE; --- 834,851 ---- /* Try to collapse intrinsic expressions. */ ! static gfc_try simplify_intrinsic_op (gfc_expr *p, int type) { gfc_intrinsic_op op; gfc_expr *op1, *op2, *result; ! if (p->value.op.op == INTRINSIC_USER) return SUCCESS; op1 = p->value.op.op1; op2 = p->value.op.op2; ! op = p->value.op.op; if (gfc_simplify_expr (op1, type) == FAILURE) return FAILURE; *************** simplify_intrinsic_op (gfc_expr *p, int *** 960,966 **** /* Subroutine to simplify constructor expressions. Mutually recursive with gfc_simplify_expr(). */ ! static try simplify_constructor (gfc_constructor *c, int type) { gfc_expr *p; --- 970,976 ---- /* Subroutine to simplify constructor expressions. Mutually recursive with gfc_simplify_expr(). */ ! static gfc_try simplify_constructor (gfc_constructor *c, int type) { gfc_expr *p; *************** simplify_constructor (gfc_constructor *c *** 996,1002 **** /* 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) { --- 1006,1012 ---- /* Pull a single array element out of an array constructor. */ ! static gfc_try find_array_element (gfc_constructor *cons, gfc_array_ref *ar, gfc_constructor **rval) { *************** find_array_element (gfc_constructor *con *** 1007,1013 **** mpz_t span; mpz_t tmp; gfc_expr *e; ! try t; t = SUCCESS; e = NULL; --- 1017,1023 ---- mpz_t span; mpz_t tmp; gfc_expr *e; ! gfc_try t; t = SUCCESS; e = NULL; *************** find_array_element (gfc_constructor *con *** 1060,1068 **** mpz_mul (span, span, tmp); } ! if (cons) { ! for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) { if (cons->iterator) { --- 1070,1078 ---- mpz_mul (span, span, tmp); } ! for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) { ! if (cons) { if (cons->iterator) { *************** remove_subobject_ref (gfc_expr *p, gfc_c *** 1123,1129 **** /* Pull an array section out of an array constructor. */ ! static try find_array_section (gfc_expr *expr, gfc_ref *ref) { int idx; --- 1133,1139 ---- /* Pull an array section out of an array constructor. */ ! static gfc_try find_array_section (gfc_expr *expr, gfc_ref *ref) { int idx; *************** find_array_section (gfc_expr *expr, gfc_ *** 1150,1156 **** gfc_expr *upper; gfc_expr *lower; gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c; ! try t; t = SUCCESS; --- 1160,1166 ---- gfc_expr *upper; gfc_expr *lower; gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c; ! gfc_try t; t = SUCCESS; *************** find_array_section (gfc_expr *expr, gfc_ *** 1350,1356 **** cons = base; } ! while (mpz_cmp (ptr, index) > 0) { mpz_add_ui (index, index, one); cons = cons->next; --- 1360,1366 ---- cons = base; } ! while (cons && cons->next && mpz_cmp (ptr, index) > 0) { mpz_add_ui (index, index, one); cons = cons->next; *************** cleanup: *** 1381,1393 **** /* Pull a substring out of an expression. */ ! static try find_substring_ref (gfc_expr *p, gfc_expr **newp) { int end; int start; int length; ! char *chr; if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) --- 1391,1403 ---- /* Pull a substring out of an expression. */ ! static gfc_try find_substring_ref (gfc_expr *p, gfc_expr **newp) { int end; int start; int length; ! gfc_char_t *chr; if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) *************** find_substring_ref (gfc_expr *p, gfc_exp *** 1400,1408 **** start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer); length = end - start + 1; ! chr = (*newp)->value.character.string = gfc_getmem (length + 1); (*newp)->value.character.length = length; ! memcpy (chr, &p->value.character.string[start - 1], length); chr[length] = '\0'; return SUCCESS; } --- 1410,1419 ---- start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer); length = end - start + 1; ! chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1); (*newp)->value.character.length = length; ! memcpy (chr, &p->value.character.string[start - 1], ! length * sizeof (gfc_char_t)); chr[length] = '\0'; return SUCCESS; } *************** find_substring_ref (gfc_expr *p, gfc_exp *** 1412,1418 **** /* Simplify a subobject reference of a constructor. This occurs when parameter variable values are substituted. */ ! static try simplify_const_ref (gfc_expr *p) { gfc_constructor *cons; --- 1423,1429 ---- /* Simplify a subobject reference of a constructor. This occurs when parameter variable values are substituted. */ ! static gfc_try simplify_const_ref (gfc_expr *p) { gfc_constructor *cons; *************** simplify_const_ref (gfc_expr *p) *** 1450,1457 **** cons = p->value.constructor; for (; cons; cons = cons->next) { ! cons->expr->ref = copy_ref (p->ref->next); ! simplify_const_ref (cons->expr); if (simplify_const_ref (cons->expr) == FAILURE) return FAILURE; } --- 1461,1467 ---- cons = p->value.constructor; for (; cons; cons = cons->next) { ! cons->expr->ref = gfc_copy_ref (p->ref->next); if (simplify_const_ref (cons->expr) == FAILURE) return FAILURE; } *************** simplify_const_ref (gfc_expr *p) *** 1520,1526 **** /* Simplify a chain of references. */ ! static try simplify_ref_chain (gfc_ref *ref, int type) { int n; --- 1530,1536 ---- /* Simplify a chain of references. */ ! static gfc_try simplify_ref_chain (gfc_ref *ref, int type) { int n; *************** simplify_ref_chain (gfc_ref *ref, int ty *** 1558,1568 **** /* Try to substitute the value of a parameter variable. */ ! static try simplify_parameter_variable (gfc_expr *p, int type) { gfc_expr *e; ! try t; e = gfc_copy_expr (p->symtree->n.sym->value); if (e == NULL) --- 1568,1578 ---- /* Try to substitute the value of a parameter variable. */ ! static gfc_try simplify_parameter_variable (gfc_expr *p, int type) { gfc_expr *e; ! gfc_try t; e = gfc_copy_expr (p->symtree->n.sym->value); if (e == NULL) *************** simplify_parameter_variable (gfc_expr *p *** 1572,1578 **** /* Do not copy subobject refs for constant. */ if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) ! e->ref = copy_ref (p->ref); t = gfc_simplify_expr (e, type); /* Only use the simplification if it eliminated all subobject references. */ --- 1582,1588 ---- /* Do not copy subobject refs for constant. */ if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) ! e->ref = gfc_copy_ref (p->ref); t = gfc_simplify_expr (e, type); /* Only use the simplification if it eliminated all subobject references. */ *************** simplify_parameter_variable (gfc_expr *p *** 1603,1609 **** Returns FAILURE on error, SUCCESS otherwise. NOTE: Will return SUCCESS even if the expression can not be simplified. */ ! try gfc_simplify_expr (gfc_expr *p, int type) { gfc_actual_arglist *ap; --- 1613,1619 ---- Returns FAILURE on error, SUCCESS otherwise. NOTE: Will return SUCCESS even if the expression can not be simplified. */ ! gfc_try gfc_simplify_expr (gfc_expr *p, int type) { gfc_actual_arglist *ap; *************** gfc_simplify_expr (gfc_expr *p, int type *** 1634,1640 **** if (gfc_is_constant_expr (p)) { ! char *s; int start, end; if (p->ref && p->ref->u.ss.start) --- 1644,1650 ---- if (gfc_is_constant_expr (p)) { ! gfc_char_t *s; int start, end; if (p->ref && p->ref->u.ss.start) *************** gfc_simplify_expr (gfc_expr *p, int type *** 1650,1657 **** else end = p->value.character.length; ! s = gfc_getmem (end - start + 2); ! memcpy (s, p->value.character.string + start, end - start); s[end - start + 1] = '\0'; /* TODO: C-style string. */ gfc_free (p->value.character.string); p->value.character.string = s; --- 1660,1668 ---- else end = p->value.character.length; ! s = gfc_get_wide_string (end - start + 2); ! memcpy (s, p->value.character.string + start, ! (end - start) * sizeof (gfc_char_t)); s[end - start + 1] = '\0'; /* TODO: C-style string. */ gfc_free (p->value.character.string); p->value.character.string = s; *************** gfc_simplify_expr (gfc_expr *p, int type *** 1710,1715 **** --- 1721,1730 ---- return FAILURE; break; + + case EXPR_COMPCALL: + gcc_unreachable (); + break; } return SUCCESS; *************** et0 (gfc_expr *e) *** 1733,1744 **** /* Check an intrinsic arithmetic operation to see if it is consistent with some type of expression. */ ! static try check_init_expr (gfc_expr *); /* Scalarize an expression for an elemental intrinsic call. */ ! static try scalarize_intrinsic_call (gfc_expr *e) { gfc_actual_arglist *a, *b; --- 1748,1759 ---- /* Check an intrinsic arithmetic operation to see if it is consistent with some type of expression. */ ! static gfc_try check_init_expr (gfc_expr *); /* Scalarize an expression for an elemental intrinsic call. */ ! static gfc_try scalarize_intrinsic_call (gfc_expr *e) { gfc_actual_arglist *a, *b; *************** cleanup: *** 1871,1878 **** } ! static try ! check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *)) { gfc_expr *op1 = e->value.op.op1; gfc_expr *op2 = e->value.op.op2; --- 1886,1893 ---- } ! static gfc_try ! check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *)) { gfc_expr *op1 = e->value.op.op1; gfc_expr *op2 = e->value.op.op2; *************** check_intrinsic_op (gfc_expr *e, try (*c *** 1880,1886 **** if ((*check_function) (op1) == FAILURE) return FAILURE; ! switch (e->value.op.operator) { case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: --- 1895,1901 ---- if ((*check_function) (op1) == FAILURE) return FAILURE; ! switch (e->value.op.op) { case INTRINSIC_UPLUS: case INTRINSIC_UMINUS: *************** check_intrinsic_op (gfc_expr *e, try (*c *** 1923,1929 **** if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) goto not_numeric; ! if (e->value.op.operator == INTRINSIC_POWER && check_function == check_init_expr && et0 (op2) != BT_INTEGER) { if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger " --- 1938,1944 ---- if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) goto not_numeric; ! if (e->value.op.op == INTRINSIC_POWER && check_function == check_init_expr && et0 (op2) != BT_INTEGER) { if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger " *************** check_init_expr_arguments (gfc_expr *e) *** 2011,2018 **** return MATCH_YES; } ! ! static try check_restricted (gfc_expr *); /* F95, 7.1.6.1, Initialization expressions, (7) F2003, 7.1.7 Initialization expression, (8) */ --- 2026,2032 ---- return MATCH_YES; } ! static gfc_try check_restricted (gfc_expr *); /* F95, 7.1.6.1, Initialization expressions, (7) F2003, 7.1.7 Initialization expression, (8) */ *************** check_conversion (gfc_expr *e) *** 2203,2214 **** intrinsics in the context of initialization expressions. If FAILURE is returned an error message has been generated. */ ! static try check_init_expr (gfc_expr *e) { match m; ! try t; ! gfc_intrinsic_sym *isym; if (e == NULL) return SUCCESS; --- 2217,2227 ---- intrinsics in the context of initialization expressions. If FAILURE is returned an error message has been generated. */ ! static gfc_try check_init_expr (gfc_expr *e) { match m; ! gfc_try t; if (e == NULL) return SUCCESS; *************** check_init_expr (gfc_expr *e) *** 2227,2233 **** if ((m = check_specification_function (e)) != MATCH_YES) { ! if ((m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES) { gfc_error ("Function '%s' in initialization expression at %L " "must be an intrinsic or a specification function", --- 2240,2251 ---- if ((m = check_specification_function (e)) != MATCH_YES) { ! gfc_intrinsic_sym* isym; ! gfc_symbol* sym; ! ! sym = e->symtree->n.sym; ! if (!gfc_is_intrinsic (sym, 0, e->where) ! || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES) { gfc_error ("Function '%s' in initialization expression at %L " "must be an intrinsic or a specification function", *************** check_init_expr (gfc_expr *e) *** 2249,2255 **** /* Try to scalarize an elemental intrinsic function that has an array argument. */ ! isym = gfc_find_function (e->symtree->n.sym->name); if (isym && isym->elemental && (t = scalarize_intrinsic_call (e)) == SUCCESS) break; --- 2267,2273 ---- /* Try to scalarize an elemental intrinsic function that has an array argument. */ ! isym = gfc_find_function (e->symtree->n.sym->name); if (isym && isym->elemental && (t = scalarize_intrinsic_call (e)) == SUCCESS) break; *************** check_init_expr (gfc_expr *e) *** 2369,2383 **** return t; } - /* Reduces a general expression to an initialization expression (a constant). This used to be part of gfc_match_init_expr. Note that this function doesn't free the given expression on FAILURE. */ ! ! try gfc_reduce_init_expr (gfc_expr *expr) { ! try t; gfc_init_expr = 1; t = gfc_resolve_expr (expr); --- 2387,2400 ---- return t; } /* Reduces a general expression to an initialization expression (a constant). This used to be part of gfc_match_init_expr. Note that this function doesn't free the given expression on FAILURE. */ ! ! gfc_try gfc_reduce_init_expr (gfc_expr *expr) { ! gfc_try t; gfc_init_expr = 1; t = gfc_resolve_expr (expr); *************** gfc_match_init_expr (gfc_expr **result) *** 2414,2420 **** { gfc_expr *expr; match m; ! try t; expr = NULL; --- 2431,2437 ---- { gfc_expr *expr; match m; ! gfc_try t; expr = NULL; *************** gfc_match_init_expr (gfc_expr **result) *** 2439,2445 **** restricted expression and optionally if the expression type is integer or character. */ ! static try restricted_args (gfc_actual_arglist *a) { for (; a; a = a->next) --- 2456,2462 ---- restricted expression and optionally if the expression type is integer or character. */ ! static gfc_try restricted_args (gfc_actual_arglist *a) { for (; a; a = a->next) *************** restricted_args (gfc_actual_arglist *a) *** 2457,2463 **** /* Make sure a non-intrinsic function is a specification function. */ ! static try external_spec_function (gfc_expr *e) { gfc_symbol *f; --- 2474,2480 ---- /* Make sure a non-intrinsic function is a specification function. */ ! static gfc_try external_spec_function (gfc_expr *e) { gfc_symbol *f; *************** external_spec_function (gfc_expr *e) *** 2499,2505 **** /* Check to see that a function reference to an intrinsic is a restricted expression. */ ! static try restricted_intrinsic (gfc_expr *e) { /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ --- 2516,2522 ---- /* Check to see that a function reference to an intrinsic is a restricted expression. */ ! static gfc_try restricted_intrinsic (gfc_expr *e) { /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ *************** restricted_intrinsic (gfc_expr *e) *** 2510,2524 **** } /* Verify that an expression is a restricted expression. Like its cousin check_init_expr(), an error message is generated if we return FAILURE. */ ! static try check_restricted (gfc_expr *e) { ! gfc_symbol *sym; ! try t; if (e == NULL) return SUCCESS; --- 2527,2599 ---- } + /* Check the expressions of an actual arglist. Used by check_restricted. */ + + static gfc_try + check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*)) + { + for (; arg; arg = arg->next) + if (checker (arg->expr) == FAILURE) + return FAILURE; + + return SUCCESS; + } + + + /* Check the subscription expressions of a reference chain with a checking + function; used by check_restricted. */ + + static gfc_try + check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*)) + { + int dim; + + if (!ref) + return SUCCESS; + + switch (ref->type) + { + case REF_ARRAY: + for (dim = 0; dim != ref->u.ar.dimen; ++dim) + { + if (checker (ref->u.ar.start[dim]) == FAILURE) + return FAILURE; + if (checker (ref->u.ar.end[dim]) == FAILURE) + return FAILURE; + if (checker (ref->u.ar.stride[dim]) == FAILURE) + return FAILURE; + } + break; + + case REF_COMPONENT: + /* Nothing needed, just proceed to next reference. */ + break; + + case REF_SUBSTRING: + if (checker (ref->u.ss.start) == FAILURE) + return FAILURE; + if (checker (ref->u.ss.end) == FAILURE) + return FAILURE; + break; + + default: + gcc_unreachable (); + break; + } + + return check_references (ref->next, checker); + } + + /* Verify that an expression is a restricted expression. Like its cousin check_init_expr(), an error message is generated if we return FAILURE. */ ! static gfc_try check_restricted (gfc_expr *e) { ! gfc_symbol* sym; ! gfc_try t; if (e == NULL) return SUCCESS; *************** check_restricted (gfc_expr *e) *** 2533,2540 **** break; case EXPR_FUNCTION: ! t = e->value.function.esym ? external_spec_function (e) ! : restricted_intrinsic (e); break; case EXPR_VARIABLE: --- 2608,2629 ---- break; case EXPR_FUNCTION: ! if (e->value.function.esym) ! { ! t = check_arglist (e->value.function.actual, &check_restricted); ! if (t == SUCCESS) ! t = external_spec_function (e); ! } ! else ! { ! if (e->value.function.isym && e->value.function.isym->inquiry) ! t = SUCCESS; ! else ! t = check_arglist (e->value.function.actual, &check_restricted); ! ! if (t == SUCCESS) ! t = restricted_intrinsic (e); ! } break; case EXPR_VARIABLE: *************** check_restricted (gfc_expr *e) *** 2568,2573 **** --- 2657,2666 ---- break; } + /* Check reference chain if any. */ + if (check_references (e->ref, &check_restricted) == FAILURE) + break; + /* gfc_is_formal_arg broadcasts that a formal argument list is being processed in resolve.c(resolve_formal_arglist). This is done so that host associated dummy array indices are accepted (PR23446). *************** check_restricted (gfc_expr *e) *** 2578,2583 **** --- 2671,2677 ---- || sym->attr.use_assoc || sym->attr.dummy || sym->attr.implied_index + || sym->attr.flavor == FL_PARAMETER || (sym->ns && sym->ns == gfc_current_ns->parent) || (sym->ns && gfc_current_ns->parent && sym->ns == gfc_current_ns->parent->parent) *************** check_restricted (gfc_expr *e) *** 2630,2636 **** /* Check to see that an expression is a specification expression. If we return FAILURE, an error has been generated. */ ! try gfc_specification_expr (gfc_expr *e) { --- 2724,2730 ---- /* Check to see that an expression is a specification expression. If we return FAILURE, an error has been generated. */ ! gfc_try gfc_specification_expr (gfc_expr *e) { *************** gfc_specification_expr (gfc_expr *e) *** 2639,2645 **** if (e->ts.type != BT_INTEGER) { ! gfc_error ("Expression at %L must be of INTEGER type", &e->where); return FAILURE; } --- 2733,2740 ---- if (e->ts.type != BT_INTEGER) { ! gfc_error ("Expression at %L must be of INTEGER type, found %s", ! &e->where, gfc_basic_typename (e->ts.type)); return FAILURE; } *************** gfc_specification_expr (gfc_expr *e) *** 2672,2683 **** /* Given two expressions, make sure that the arrays are conformable. */ ! try gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2) { int op1_flag, op2_flag, d; mpz_t op1_size, op2_size; ! try t; if (op1->rank == 0 || op2->rank == 0) return SUCCESS; --- 2767,2778 ---- /* Given two expressions, make sure that the arrays are conformable. */ ! gfc_try gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2) { int op1_flag, op2_flag, d; mpz_t op1_size, op2_size; ! gfc_try t; if (op1->rank == 0 || op2->rank == 0) return SUCCESS; *************** gfc_check_conformance (const char *optyp *** 2722,2728 **** /* Given an assignable expression and an arbitrary expression, make sure that the assignment can take place. */ ! try gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) { gfc_symbol *sym; --- 2817,2823 ---- /* Given an assignable expression and an arbitrary expression, make sure that the assignment can take place. */ ! gfc_try gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) { gfc_symbol *sym; *************** gfc_check_assign (gfc_expr *lvalue, gfc_ *** 2736,2742 **** has_pointer = sym->attr.pointer; for (ref = lvalue->ref; ref; ref = ref->next) ! if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) { has_pointer = 1; break; --- 2831,2837 ---- has_pointer = sym->attr.pointer; for (ref = lvalue->ref; ref; ref = ref->next) ! if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) { has_pointer = 1; break; *************** gfc_check_assign (gfc_expr *lvalue, gfc_ *** 2906,2918 **** if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) return SUCCESS; ! gfc_error ("Incompatible types in assignment at %L, %s to %s", ! &lvalue->where, gfc_typename (&rvalue->ts), ! gfc_typename (&lvalue->ts)); return FAILURE; } return gfc_convert_type (rvalue, &lvalue->ts, 1); } --- 3001,3023 ---- if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) return SUCCESS; ! gfc_error ("Incompatible types in DATA statement at %L; attempted " ! "conversion of %s to %s", &lvalue->where, ! gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); return FAILURE; } + /* Assignment is the only case where character variables of different + kind values can be converted into one another. */ + if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) + { + if (lvalue->ts.kind != rvalue->ts.kind) + gfc_convert_chartype (rvalue, &lvalue->ts); + + return SUCCESS; + } + return gfc_convert_type (rvalue, &lvalue->ts, 1); } *************** gfc_check_assign (gfc_expr *lvalue, gfc_ *** 2921,2927 **** we only check rvalue if it's not an assignment to NULL() or a NULLIFY statement. */ ! try gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { symbol_attribute attr; --- 3026,3032 ---- we only check rvalue if it's not an assignment to NULL() or a NULLIFY statement. */ ! gfc_try gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { symbol_attribute attr; *************** gfc_check_pointer_assign (gfc_expr *lval *** 2929,2935 **** int is_pure; int pointer, check_intent_in; ! if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN) { gfc_error ("Pointer assignment target is not a POINTER at %L", &lvalue->where); --- 3034,3041 ---- int is_pure; int pointer, check_intent_in; ! if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN ! && !lvalue->symtree->n.sym->attr.proc_pointer) { gfc_error ("Pointer assignment target is not a POINTER at %L", &lvalue->where); *************** gfc_check_pointer_assign (gfc_expr *lval *** 2937,2943 **** } if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE ! && lvalue->symtree->n.sym->attr.use_assoc) { gfc_error ("'%s' in the pointer assignment at %L cannot be an " "l-value since it is a procedure", --- 3043,3050 ---- } if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE ! && lvalue->symtree->n.sym->attr.use_assoc ! && !lvalue->symtree->n.sym->attr.proc_pointer) { gfc_error ("'%s' in the pointer assignment at %L cannot be an " "l-value since it is a procedure", *************** gfc_check_pointer_assign (gfc_expr *lval *** 2949,2962 **** /* Check INTENT(IN), unless the object itself is the component or sub-component of a pointer. */ check_intent_in = 1; ! pointer = lvalue->symtree->n.sym->attr.pointer; for (ref = lvalue->ref; ref; ref = ref->next) { if (pointer) check_intent_in = 0; ! if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) pointer = 1; if (ref->type == REF_ARRAY && ref->next == NULL) --- 3056,3070 ---- /* Check INTENT(IN), unless the object itself is the component or sub-component of a pointer. */ check_intent_in = 1; ! pointer = lvalue->symtree->n.sym->attr.pointer ! | lvalue->symtree->n.sym->attr.proc_pointer; for (ref = lvalue->ref; ref; ref = ref->next) { if (pointer) check_intent_in = 0; ! if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) pointer = 1; if (ref->type == REF_ARRAY && ref->next == NULL) *************** gfc_check_pointer_assign (gfc_expr *lval *** 3014,3023 **** if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) return SUCCESS; if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) { ! gfc_error ("Different types in pointer assignment at %L", ! &lvalue->where); return FAILURE; } --- 3122,3164 ---- if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) return SUCCESS; + /* Checks on rvalue for procedure pointer assignments. */ + if (lvalue->symtree->n.sym->attr.proc_pointer) + { + attr = gfc_expr_attr (rvalue); + if (!((rvalue->expr_type == EXPR_NULL) + || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) + || (rvalue->expr_type == EXPR_VARIABLE + && attr.flavor == FL_PROCEDURE))) + { + gfc_error ("Invalid procedure pointer assignment at %L", + &rvalue->where); + return FAILURE; + } + if (attr.abstract) + { + gfc_error ("Abstract interface '%s' is invalid " + "in procedure pointer assignment at %L", + rvalue->symtree->name, &rvalue->where); + } + /* TODO. See PR 38290. + if (rvalue->expr_type == EXPR_VARIABLE + && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN + && !gfc_compare_interfaces (lvalue->symtree->n.sym, + rvalue->symtree->n.sym, 0)) + { + gfc_error ("Interfaces don't match " + "in procedure pointer assignment at %L", &rvalue->where); + return FAILURE; + }*/ + return SUCCESS; + } + if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) { ! gfc_error ("Different types in pointer assignment at %L; attempted " ! "assignment of %s to %s", &lvalue->where, ! gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts)); return FAILURE; } *************** gfc_check_pointer_assign (gfc_expr *lval *** 3039,3053 **** if (rvalue->expr_type == EXPR_NULL) return SUCCESS; ! if (lvalue->ts.type == BT_CHARACTER ! && lvalue->ts.cl && rvalue->ts.cl ! && lvalue->ts.cl->length && rvalue->ts.cl->length ! && abs (gfc_dep_compare_expr (lvalue->ts.cl->length, ! rvalue->ts.cl->length)) == 1) { ! gfc_error ("Different character lengths in pointer " ! "assignment at %L", &lvalue->where); ! return FAILURE; } if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) --- 3180,3190 ---- if (rvalue->expr_type == EXPR_NULL) return SUCCESS; ! if (lvalue->ts.type == BT_CHARACTER) { ! gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); ! if (t == FAILURE) ! return FAILURE; } if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) *************** gfc_check_pointer_assign (gfc_expr *lval *** 3074,3080 **** return FAILURE; } ! if (attr.protected && attr.use_assoc && !attr.pointer) { gfc_error ("Pointer assignment target has PROTECTED " "attribute at %L", &rvalue->where); --- 3211,3218 ---- return FAILURE; } ! if (attr.is_protected && attr.use_assoc ! && !(attr.pointer || attr.proc_pointer)) { gfc_error ("Pointer assignment target has PROTECTED " "attribute at %L", &rvalue->where); *************** gfc_check_pointer_assign (gfc_expr *lval *** 3088,3098 **** /* Relative of gfc_check_assign() except that the lvalue is a single symbol. Used for initialization assignments. */ ! try gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) { gfc_expr lvalue; ! try r; memset (&lvalue, '\0', sizeof (gfc_expr)); --- 3226,3236 ---- /* Relative of gfc_check_assign() except that the lvalue is a single symbol. Used for initialization assignments. */ ! gfc_try gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) { gfc_expr lvalue; ! gfc_try r; memset (&lvalue, '\0', sizeof (gfc_expr)); *************** gfc_check_assign_symbol (gfc_symbol *sym *** 3104,3110 **** lvalue.symtree->n.sym = sym; lvalue.where = sym->declared_at; ! if (sym->attr.pointer) r = gfc_check_pointer_assign (&lvalue, rvalue); else r = gfc_check_assign (&lvalue, rvalue, 1); --- 3242,3248 ---- lvalue.symtree->n.sym = sym; lvalue.where = sym->declared_at; ! if (sym->attr.pointer || sym->attr.proc_pointer) r = gfc_check_pointer_assign (&lvalue, rvalue); else r = gfc_check_assign (&lvalue, rvalue, 1); *************** gfc_default_initializer (gfc_typespec *t *** 3126,3132 **** /* See if we have a default initializer. */ for (c = ts->derived->components; c; c = c->next) ! if (c->initializer || c->allocatable) break; if (!c) --- 3264,3270 ---- /* See if we have a default initializer. */ for (c = ts->derived->components; c; c = c->next) ! if (c->initializer || c->attr.allocatable) break; if (!c) *************** gfc_default_initializer (gfc_typespec *t *** 3152,3158 **** if (c->initializer) tail->expr = gfc_copy_expr (c->initializer); ! if (c->allocatable) { tail->expr = gfc_get_expr (); tail->expr->expr_type = EXPR_NULL; --- 3290,3296 ---- if (c->initializer) tail->expr = gfc_copy_expr (c->initializer); ! if (c->attr.allocatable) { tail->expr = gfc_get_expr (); tail->expr->expr_type = EXPR_NULL; *************** gfc_expr_set_symbols_referenced (gfc_exp *** 3336,3338 **** --- 3474,3569 ---- { gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); } + + + /* Walk an expression tree and check each variable encountered for being typed. + If strict is not set, a top-level variable is tolerated untyped in -std=gnu + mode as is a basic arithmetic expression using those; this is for things in + legacy-code like: + + INTEGER :: arr(n), n + INTEGER :: arr(n + 1), n + + The namespace is needed for IMPLICIT typing. */ + + static gfc_namespace* check_typed_ns; + + static bool + expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, + int* f ATTRIBUTE_UNUSED) + { + gfc_try t; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + gcc_assert (e->symtree); + t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, + true, e->where); + + return (t == FAILURE); + } + + gfc_try + gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) + { + bool error_found; + + /* If this is a top-level variable or EXPR_OP, do the check with strict given + to us. */ + if (!strict) + { + if (e->expr_type == EXPR_VARIABLE && !e->ref) + return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); + + if (e->expr_type == EXPR_OP) + { + gfc_try t = SUCCESS; + + gcc_assert (e->value.op.op1); + t = gfc_expr_check_typed (e->value.op.op1, ns, strict); + + if (t == SUCCESS && e->value.op.op2) + t = gfc_expr_check_typed (e->value.op.op2, ns, strict); + + return t; + } + } + + /* Otherwise, walk the expression and do it strictly. */ + check_typed_ns = ns; + error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0); + + return error_found ? FAILURE : SUCCESS; + } + + /* Walk an expression tree and replace all symbols with a corresponding symbol + in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE + statements. The boolean return value is required by gfc_traverse_expr. */ + + static bool + replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED) + { + if ((expr->expr_type == EXPR_VARIABLE + || (expr->expr_type == EXPR_FUNCTION + && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where))) + && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns) + { + gfc_symtree *stree; + gfc_namespace *ns = sym->formal_ns; + /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find + the symtree rather than create a new one (and probably fail later). */ + stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root, + expr->symtree->n.sym->name); + gcc_assert (stree); + stree->n.sym->attr = expr->symtree->n.sym->attr; + expr->symtree = stree; + } + return false; + } + + void + gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest) + { + gfc_traverse_expr (expr, dest, &replace_symbol, 0); + } diff -Nrcpad gcc-4.3.3/gcc/fortran/f95-lang.c gcc-4.4.0/gcc/fortran/f95-lang.c *** gcc-4.3.3/gcc/fortran/f95-lang.c Wed Apr 16 16:05:51 2008 --- gcc-4.4.0/gcc/fortran/f95-lang.c Tue Oct 7 18:15:32 2008 *************** along with GCC; see the file COPYING3. *** 29,35 **** #include "system.h" #include "coretypes.h" #include "tree.h" ! #include "tree-gimple.h" #include "flags.h" #include "langhooks.h" #include "langhooks-def.h" --- 29,35 ---- #include "system.h" #include "coretypes.h" #include "tree.h" ! #include "gimple.h" #include "flags.h" #include "langhooks.h" #include "langhooks-def.h" *************** along with GCC; see the file COPYING3. *** 45,50 **** --- 45,51 ---- #include "cgraph.h" #include "gfortran.h" + #include "cpp.h" #include "trans.h" #include "trans-types.h" #include "trans-const.h" *************** GTY(()) *** 61,67 **** union lang_tree_node GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), ! chain_next ("(union lang_tree_node *)GENERIC_NEXT (&%h.generic)"))) { union tree_node GTY((tag ("0"), --- 62,68 ---- union lang_tree_node GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), ! chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)"))) { union tree_node GTY((tag ("0"), *************** static void gfc_print_identifier (FILE * *** 95,104 **** static bool gfc_mark_addressable (tree); void do_function_end (void); int global_bindings_p (void); ! void insert_block (tree); ! static void gfc_clear_binding_stack (void); static void gfc_be_parse_file (int); static alias_set_type gfc_get_alias_set (tree); #undef LANG_HOOKS_NAME #undef LANG_HOOKS_INIT --- 96,105 ---- static bool gfc_mark_addressable (tree); void do_function_end (void); int global_bindings_p (void); ! static void clear_binding_stack (void); static void gfc_be_parse_file (int); static alias_set_type gfc_get_alias_set (tree); + static void gfc_init_ts (void); #undef LANG_HOOKS_NAME #undef LANG_HOOKS_INIT *************** static alias_set_type gfc_get_alias_set *** 111,129 **** #undef LANG_HOOKS_MARK_ADDRESSABLE #undef LANG_HOOKS_TYPE_FOR_MODE #undef LANG_HOOKS_TYPE_FOR_SIZE - #undef LANG_HOOKS_CLEAR_BINDING_STACK #undef LANG_HOOKS_GET_ALIAS_SET #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING #undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR #undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES #undef LANG_HOOKS_BUILTIN_FUNCTION #undef LANG_HOOKS_GET_ARRAY_DESCR_INFO /* Define lang hooks. */ ! #define LANG_HOOKS_NAME "GNU F95" #define LANG_HOOKS_INIT gfc_init #define LANG_HOOKS_FINISH gfc_finish #define LANG_HOOKS_INIT_OPTIONS gfc_init_options --- 112,134 ---- #undef LANG_HOOKS_MARK_ADDRESSABLE #undef LANG_HOOKS_TYPE_FOR_MODE #undef LANG_HOOKS_TYPE_FOR_SIZE #undef LANG_HOOKS_GET_ALIAS_SET + #undef LANG_HOOKS_INIT_TS #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING #undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR + #undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR + #undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP + #undef LANG_HOOKS_OMP_CLAUSE_DTOR #undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE + #undef LANG_HOOKS_OMP_PRIVATE_OUTER_REF #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES #undef LANG_HOOKS_BUILTIN_FUNCTION #undef LANG_HOOKS_GET_ARRAY_DESCR_INFO /* Define lang hooks. */ ! #define LANG_HOOKS_NAME "GNU Fortran" #define LANG_HOOKS_INIT gfc_init #define LANG_HOOKS_FINISH gfc_finish #define LANG_HOOKS_INIT_OPTIONS gfc_init_options *************** static alias_set_type gfc_get_alias_set *** 131,146 **** #define LANG_HOOKS_POST_OPTIONS gfc_post_options #define LANG_HOOKS_PRINT_IDENTIFIER gfc_print_identifier #define LANG_HOOKS_PARSE_FILE gfc_be_parse_file ! #define LANG_HOOKS_MARK_ADDRESSABLE gfc_mark_addressable ! #define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode ! #define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size ! #define LANG_HOOKS_CLEAR_BINDING_STACK gfc_clear_binding_stack ! #define LANG_HOOKS_GET_ALIAS_SET gfc_get_alias_set #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference #define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing #define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor #define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR gfc_omp_disregard_value_expr #define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE gfc_omp_private_debug_clause #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \ gfc_omp_firstprivatize_type_sizes #define LANG_HOOKS_BUILTIN_FUNCTION gfc_builtin_function --- 136,155 ---- #define LANG_HOOKS_POST_OPTIONS gfc_post_options #define LANG_HOOKS_PRINT_IDENTIFIER gfc_print_identifier #define LANG_HOOKS_PARSE_FILE gfc_be_parse_file ! #define LANG_HOOKS_MARK_ADDRESSABLE gfc_mark_addressable ! #define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode ! #define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size ! #define LANG_HOOKS_GET_ALIAS_SET gfc_get_alias_set ! #define LANG_HOOKS_INIT_TS gfc_init_ts #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference #define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing #define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor + #define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR gfc_omp_clause_copy_ctor + #define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP gfc_omp_clause_assign_op + #define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor #define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR gfc_omp_disregard_value_expr #define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE gfc_omp_private_debug_clause + #define LANG_HOOKS_OMP_PRIVATE_OUTER_REF gfc_omp_private_outer_ref #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \ gfc_omp_firstprivatize_type_sizes #define LANG_HOOKS_BUILTIN_FUNCTION gfc_builtin_function *************** static alias_set_type gfc_get_alias_set *** 148,187 **** const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; - /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function - that have names. Here so we can clear out their names' definitions - at the end of the function. */ - - /* Tree code classes. */ - - #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, - - const enum tree_code_class tree_code_type[] = { - #include "tree.def" - }; - #undef DEFTREECODE - - /* Table indexed by tree code giving number of expression - operands beyond the fixed part of the node structure. - Not used for types or decls. */ - - #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, - - const unsigned char tree_code_length[] = { - #include "tree.def" - }; - #undef DEFTREECODE - - /* Names of tree components. - Used for printing out the tree and error messages. */ - #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, - - const char *const tree_code_name[] = { - #include "tree.def" - }; - #undef DEFTREECODE - - #define NULL_BINDING_LEVEL (struct binding_level *) NULL /* A chain of binding_level structures awaiting reuse. */ --- 157,162 ---- *************** gfc_truthvalue_conversion (tree expr) *** 220,235 **** return expr; } else if (TREE_CODE (expr) == NOP_EXPR) ! return build1 (NOP_EXPR, boolean_type_node, TREE_OPERAND (expr, 0)); else ! return build1 (NOP_EXPR, boolean_type_node, expr); case INTEGER_TYPE: if (TREE_CODE (expr) == INTEGER_CST) return integer_zerop (expr) ? boolean_false_node : boolean_true_node; else ! return build2 (NE_EXPR, boolean_type_node, expr, ! build_int_cst (TREE_TYPE (expr), 0)); default: internal_error ("Unexpected type in truthvalue_conversion"); --- 195,211 ---- return expr; } else if (TREE_CODE (expr) == NOP_EXPR) ! return fold_build1 (NOP_EXPR, ! boolean_type_node, TREE_OPERAND (expr, 0)); else ! return fold_build1 (NOP_EXPR, boolean_type_node, expr); case INTEGER_TYPE: if (TREE_CODE (expr) == INTEGER_CST) return integer_zerop (expr) ? boolean_false_node : boolean_true_node; else ! return fold_build2 (NE_EXPR, boolean_type_node, expr, ! build_int_cst (TREE_TYPE (expr), 0)); default: internal_error ("Unexpected type in truthvalue_conversion"); *************** gfc_be_parse_file (int set_yydebug ATTRI *** 263,272 **** cgraph_finalize_compilation_unit (); cgraph_optimize (); ! /* Tell the frontent about any errors. */ gfc_get_errors (&warnings, &errors); errorcount += errors; warningcount += warnings; } --- 239,250 ---- cgraph_finalize_compilation_unit (); cgraph_optimize (); ! /* Tell the frontend about any errors. */ gfc_get_errors (&warnings, &errors); errorcount += errors; warningcount += warnings; + + clear_binding_stack (); } *************** gfc_be_parse_file (int set_yydebug ATTRI *** 275,294 **** static bool gfc_init (void) { ! #ifdef USE_MAPPED_LOCATION ! linemap_add (line_table, LC_ENTER, false, gfc_source_file, 1); ! linemap_add (line_table, LC_RENAME, false, "", 0); ! #endif - /* First initialize the backend. */ gfc_init_decl_processing (); gfc_static_ctors = NULL_TREE; ! /* Then the frontend. */ gfc_init_1 (); if (gfc_new_file () != SUCCESS) fatal_error ("can't open input file: %s", gfc_source_file); return true; } --- 253,277 ---- static bool gfc_init (void) { ! if (!gfc_cpp_enabled ()) ! { ! linemap_add (line_table, LC_ENTER, false, gfc_source_file, 1); ! linemap_add (line_table, LC_RENAME, false, "", 0); ! } ! else ! gfc_cpp_init_0 (); gfc_init_decl_processing (); gfc_static_ctors = NULL_TREE; ! if (gfc_cpp_enabled ()) ! gfc_cpp_init (); ! gfc_init_1 (); if (gfc_new_file () != SUCCESS) fatal_error ("can't open input file: %s", gfc_source_file); + return true; } *************** gfc_init (void) *** 296,301 **** --- 279,285 ---- static void gfc_finish (void) { + gfc_cpp_done (); gfc_done_1 (); gfc_release_include_path (); return; *************** poplevel (int keep, int reverse, int fun *** 446,459 **** current_binding_level = current_binding_level->level_chain; if (functionbody) ! { ! /* This is the top level block of a function. The ..._DECL chain stored ! in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't ! leave them in the BLOCK because they are found in the FUNCTION_DECL ! instead. */ ! DECL_INITIAL (current_function_decl) = block_node; ! BLOCK_VARS (block_node) = 0; ! } else if (block_node) { current_binding_level->blocks --- 430,441 ---- current_binding_level = current_binding_level->level_chain; if (functionbody) ! /* This is the top level block of a function. */ ! DECL_INITIAL (current_function_decl) = block_node; ! else if (current_binding_level == global_binding_level) ! /* When using gfc_start_block/gfc_finish_block from middle-end hooks, ! don't add newly created BLOCKs as subblocks of global_binding_level. */ ! ; else if (block_node) { current_binding_level->blocks *************** poplevel (int keep, int reverse, int fun *** 474,492 **** } - /* Insert BLOCK at the end of the list of subblocks of the - current binding level. This is used when a BIND_EXPR is expanded, - to handle the BLOCK node inside the BIND_EXPR. */ - - void - insert_block (tree block) - { - TREE_USED (block) = 1; - current_binding_level->blocks - = chainon (current_binding_level->blocks, block); - } - - /* Records a ..._DECL node DECL as belonging to the current lexical scope. Returns the ..._DECL node. */ --- 456,461 ---- *************** pushdecl_top_level (tree x) *** 537,543 **** /* Clear the binding stack. */ static void ! gfc_clear_binding_stack (void) { while (!global_bindings_p ()) poplevel (0, 0, 0); --- 506,512 ---- /* Clear the binding stack. */ static void ! clear_binding_stack (void) { while (!global_bindings_p ()) poplevel (0, 0, 0); *************** gfc_init_decl_processing (void) *** 575,586 **** only use it for actual characters, not for INTEGER(1). Also, we want double_type_node to actually have double precision. */ build_common_tree_nodes (false, false); ! /* x86_64 minw32 has a sizetype of "unsigned long long", most other hosts have a sizetype of "unsigned long". Therefore choose the correct size in mostly target independent way. */ ! if (TYPE_MODE (long_unsigned_type_node) == Pmode) set_sizetype (long_unsigned_type_node); ! else if (TYPE_MODE (long_long_unsigned_type_node) == Pmode) set_sizetype (long_long_unsigned_type_node); else set_sizetype (long_unsigned_type_node); --- 544,555 ---- only use it for actual characters, not for INTEGER(1). Also, we want double_type_node to actually have double precision. */ build_common_tree_nodes (false, false); ! /* x86_64 mingw32 has a sizetype of "unsigned long long", most other hosts have a sizetype of "unsigned long". Therefore choose the correct size in mostly target independent way. */ ! if (TYPE_MODE (long_unsigned_type_node) == ptr_mode) set_sizetype (long_unsigned_type_node); ! else if (TYPE_MODE (long_long_unsigned_type_node) == ptr_mode) set_sizetype (long_long_unsigned_type_node); else set_sizetype (long_unsigned_type_node); *************** gfc_mark_addressable (tree exp) *** 632,638 **** IDENTIFIER_POINTER (DECL_NAME (x))); return false; } ! pedwarn ("register variable %qs used in nested function", IDENTIFIER_POINTER (DECL_NAME (x))); } else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) --- 601,607 ---- IDENTIFIER_POINTER (DECL_NAME (x))); return false; } ! pedwarn (input_location, 0, "register variable %qs used in nested function", IDENTIFIER_POINTER (DECL_NAME (x))); } else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) *************** gfc_mark_addressable (tree exp) *** 657,663 **** } #endif ! pedwarn ("address of register variable %qs requested", IDENTIFIER_POINTER (DECL_NAME (x))); } --- 626,632 ---- } #endif ! pedwarn (input_location, 0, "address of register variable %qs requested", IDENTIFIER_POINTER (DECL_NAME (x))); } *************** build_builtin_fntypes (tree *fntype, tre *** 757,762 **** --- 726,741 ---- tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node); tmp = tree_cons (NULL_TREE, type, tmp); fntype[2] = build_function_type (type, tmp); + /* type (*) (void) */ + fntype[3] = build_function_type (type, void_list_node); + /* type (*) (type, &int) */ + tmp = tree_cons (NULL_TREE, type, void_list_node); + tmp = tree_cons (NULL_TREE, build_pointer_type (integer_type_node), tmp); + fntype[4] = build_function_type (type, tmp); + /* type (*) (type, int) */ + tmp = tree_cons (NULL_TREE, type, void_list_node); + tmp = tree_cons (NULL_TREE, integer_type_node, tmp); + fntype[5] = build_function_type (type, tmp); } *************** gfc_init_builtin_functions (void) *** 807,818 **** ATTR_CONST_NOTHROW_LIST }; ! tree mfunc_float[3]; ! tree mfunc_double[3]; ! tree mfunc_longdouble[3]; ! tree mfunc_cfloat[3]; ! tree mfunc_cdouble[3]; ! tree mfunc_clongdouble[3]; tree func_cfloat_float, func_float_cfloat; tree func_cdouble_double, func_double_cdouble; tree func_clongdouble_longdouble, func_longdouble_clongdouble; --- 786,797 ---- ATTR_CONST_NOTHROW_LIST }; ! tree mfunc_float[6]; ! tree mfunc_double[6]; ! tree mfunc_longdouble[6]; ! tree mfunc_cfloat[6]; ! tree mfunc_cdouble[6]; ! tree mfunc_clongdouble[6]; tree func_cfloat_float, func_float_cfloat; tree func_cdouble_double, func_double_cdouble; tree func_clongdouble_longdouble, func_longdouble_clongdouble; *************** gfc_init_builtin_functions (void) *** 903,908 **** --- 882,915 ---- gfc_define_builtin ("__builtin_copysignf", mfunc_float[1], BUILT_IN_COPYSIGNF, "copysignf", true); + gfc_define_builtin ("__builtin_nextafterl", mfunc_longdouble[1], + BUILT_IN_NEXTAFTERL, "nextafterl", true); + gfc_define_builtin ("__builtin_nextafter", mfunc_double[1], + BUILT_IN_NEXTAFTER, "nextafter", true); + gfc_define_builtin ("__builtin_nextafterf", mfunc_float[1], + BUILT_IN_NEXTAFTERF, "nextafterf", true); + + gfc_define_builtin ("__builtin_frexpl", mfunc_longdouble[4], + BUILT_IN_FREXPL, "frexpl", false); + gfc_define_builtin ("__builtin_frexp", mfunc_double[4], + BUILT_IN_FREXP, "frexp", false); + gfc_define_builtin ("__builtin_frexpf", mfunc_float[4], + BUILT_IN_FREXPF, "frexpf", false); + + gfc_define_builtin ("__builtin_fabsl", mfunc_longdouble[0], + BUILT_IN_FABSL, "fabsl", true); + gfc_define_builtin ("__builtin_fabs", mfunc_double[0], + BUILT_IN_FABS, "fabs", true); + gfc_define_builtin ("__builtin_fabsf", mfunc_float[0], + BUILT_IN_FABSF, "fabsf", true); + + gfc_define_builtin ("__builtin_scalbnl", mfunc_longdouble[5], + BUILT_IN_SCALBNL, "scalbnl", true); + gfc_define_builtin ("__builtin_scalbn", mfunc_double[5], + BUILT_IN_SCALBN, "scalbn", true); + gfc_define_builtin ("__builtin_scalbnf", mfunc_float[5], + BUILT_IN_SCALBNF, "scalbnf", true); + gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1], BUILT_IN_FMODL, "fmodl", true); gfc_define_builtin ("__builtin_fmod", mfunc_double[1], *************** gfc_init_builtin_functions (void) *** 910,915 **** --- 917,929 ---- gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], BUILT_IN_FMODF, "fmodf", true); + gfc_define_builtin ("__builtin_infl", mfunc_longdouble[3], + BUILT_IN_INFL, "__builtin_infl", true); + gfc_define_builtin ("__builtin_inf", mfunc_double[3], + BUILT_IN_INF, "__builtin_inf", true); + gfc_define_builtin ("__builtin_inff", mfunc_float[3], + BUILT_IN_INFF, "__builtin_inff", true); + /* lround{f,,l} and llround{f,,l} */ type = tree_cons (NULL_TREE, float_type_node, void_list_node); tmp = build_function_type (long_integer_type_node, type); *************** gfc_init_builtin_functions (void) *** 983,988 **** --- 997,1033 ---- BUILT_IN_SINCOSF, "sincosf", false); } + /* For LEADZ / TRAILZ. */ + tmp = tree_cons (NULL_TREE, unsigned_type_node, void_list_node); + ftype = build_function_type (integer_type_node, tmp); + gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, + "__builtin_clz", true); + + tmp = tree_cons (NULL_TREE, long_unsigned_type_node, void_list_node); + ftype = build_function_type (integer_type_node, tmp); + gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, + "__builtin_clzl", true); + + tmp = tree_cons (NULL_TREE, long_long_unsigned_type_node, void_list_node); + ftype = build_function_type (integer_type_node, tmp); + gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, + "__builtin_clzll", true); + + tmp = tree_cons (NULL_TREE, unsigned_type_node, void_list_node); + ftype = build_function_type (integer_type_node, tmp); + gfc_define_builtin ("__builtin_ctz", ftype, BUILT_IN_CTZ, + "__builtin_ctz", true); + + tmp = tree_cons (NULL_TREE, long_unsigned_type_node, void_list_node); + ftype = build_function_type (integer_type_node, tmp); + gfc_define_builtin ("__builtin_ctzl", ftype, BUILT_IN_CTZL, + "__builtin_ctzl", true); + + tmp = tree_cons (NULL_TREE, long_long_unsigned_type_node, void_list_node); + ftype = build_function_type (integer_type_node, tmp); + gfc_define_builtin ("__builtin_ctzll", ftype, BUILT_IN_CTZLL, + "__builtin_ctzll", true); + /* Other builtin functions we use. */ tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node); *************** gfc_init_builtin_functions (void) *** 1172,1176 **** --- 1217,1231 ---- #undef DEFINE_MATH_BUILTIN_C #undef DEFINE_MATH_BUILTIN + static void + gfc_init_ts (void) + { + tree_contains_struct[NAMESPACE_DECL][TS_DECL_NON_COMMON] = 1; + tree_contains_struct[NAMESPACE_DECL][TS_DECL_WITH_VIS] = 1; + tree_contains_struct[NAMESPACE_DECL][TS_DECL_WRTL] = 1; + tree_contains_struct[NAMESPACE_DECL][TS_DECL_COMMON] = 1; + tree_contains_struct[NAMESPACE_DECL][TS_DECL_MINIMAL] = 1; + } + #include "gt-fortran-f95-lang.h" #include "gtype-fortran.h" diff -Nrcpad gcc-4.3.3/gcc/fortran/gfc-internals.texi gcc-4.4.0/gcc/fortran/gfc-internals.texi *** gcc-4.3.3/gcc/fortran/gfc-internals.texi Sun Apr 15 14:28:43 2007 --- gcc-4.4.0/gcc/fortran/gfc-internals.texi Mon Sep 1 10:55:50 2008 *************** *** 1,7 **** \input texinfo @c -*-texinfo-*- @c %**start of header @setfilename gfc-internals.info ! @set copyrights-gfortran 2007 @include gcc-common.texi --- 1,7 ---- \input texinfo @c -*-texinfo-*- @c %**start of header @setfilename gfc-internals.info ! @set copyrights-gfortran 2007-2008 @include gcc-common.texi *************** *** 34,44 **** Copyright @copyright{} @value{copyrights-gfortran} Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document ! under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with the ! Invariant Sections being ``GNU General Public License'' and ``Funding ! Free Software'', the Front-Cover ! texts being (a) (see below), and with the Back-Cover Texts being (b) (see below). A copy of the license is included in the section entitled ``GNU Free Documentation License''. --- 34,43 ---- Copyright @copyright{} @value{copyrights-gfortran} Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document ! under the terms of the GNU Free Documentation License, Version 1.2 or any later version published by the Free Software Foundation; with the ! Invariant Sections being ``Funding Free Software'', the Front-Cover ! Texts being (a) (see below), and with the Back-Cover Texts being (b) (see below). A copy of the license is included in the section entitled ``GNU Free Documentation License''. *************** not accurately reflect the status of the *** 119,127 **** * User Interface:: Code that Interacts with the User. * Frontend Data Structures:: Data structures used by the frontend * LibGFortran:: The LibGFortran Runtime Library. * GNU Free Documentation License:: ! How you can copy and share this manual. * Index:: Index of this documentation. @end menu @end ifnottex --- 118,127 ---- * User Interface:: Code that Interacts with the User. * Frontend Data Structures:: Data structures used by the frontend + * Object Orientation:: Internals of Fortran 2003 OOP features. * LibGFortran:: The LibGFortran Runtime Library. * GNU Free Documentation License:: ! How you can copy and share this manual. * Index:: Index of this documentation. @end menu @end ifnottex *************** should exhaust all possible valid combin *** 284,292 **** structures. @menu ! * gfc_code:: Representation of Executable Statements @end menu @node gfc_code @section @code{gfc_code} @cindex statement chaining --- 284,297 ---- structures. @menu ! * gfc_code:: Representation of Executable Statements. ! * gfc_expr:: Representation of Values and Expressions. @end menu + + @c gfc_code + @c -------- + @node gfc_code @section @code{gfc_code} @cindex statement chaining *************** last in a block, @code{here} points to t *** 307,321 **** current statement. If the current statement is one of @code{IF}, @code{DO}, @code{SELECT} ! it starts a block, i.e. a nested level in the program. In order to represent this, the @code{block} member is set to point to a ! @code{gfc_code} structure whose @code{block} member points to the ! block in question. The @code{SELECT} and @code{IF} statements may ! contain various blocks (the chain of @code{ELSE IF} and @code{ELSE} ! blocks or the various @code{CASE}s, respectively). ! @c What would be nice here would be an example program together with ! @c an image that says more than the mythical thousand words. @c --------------------------------------------------------------------- --- 312,652 ---- current statement. If the current statement is one of @code{IF}, @code{DO}, @code{SELECT} ! it starts a block, i.e.@: a nested level in the program. In order to represent this, the @code{block} member is set to point to a ! @code{gfc_code} structure whose @code{next} member starts the chain of ! statements inside the block; this structure's @code{op} member should be set to ! the same value as the parent structure's @code{op} member. The @code{SELECT} ! and @code{IF} statements may contain various blocks (the chain of @code{ELSE IF} ! and @code{ELSE} blocks or the various @code{CASE}s, respectively). These chains ! are linked-lists formed by the @code{block} members. ! Consider the following example code: ! ! @example ! IF (foo < 20) THEN ! PRINT *, "Too small" ! foo = 20 ! ELSEIF (foo > 50) THEN ! PRINT *, "Too large" ! foo = 50 ! ELSE ! PRINT *, "Good" ! END IF ! @end example ! ! This statement-block will be represented in the internal gfortran tree as ! follows, were the horizontal link-chains are those induced by the @code{next} ! members and vertical links down are those of @code{block}. @samp{==|} and ! @samp{--|} mean @code{NULL} pointers to mark the end of a chain: ! ! @example ! ... ==> IF ==> ... ! | ! +--> IF foo < 20 ==> PRINT *, "Too small" ==> foo = 20 ==| ! | ! +--> IF foo > 50 ==> PRINT *, "Too large" ==> foo = 50 ==| ! | ! +--> ELSE ==> PRINT *, "Good" ==| ! | ! +--| ! @end example ! ! ! @subsection IF Blocks ! ! Conditionals are represented by @code{gfc_code} structures with their ! @code{op} member set to @code{EXEC_IF}. This structure's @code{block} ! member must point to another @code{gfc_code} node that is the header of the ! if-block. This header's @code{op} member must be set to @code{EXEC_IF}, too, ! its @code{expr} member holds the condition to check for, and its @code{next} ! should point to the code-chain of the statements to execute if the condition is ! true. ! ! If in addition an @code{ELSEIF} or @code{ELSE} block is present, the ! @code{block} member of the if-block-header node points to yet another ! @code{gfc_code} structure that is the header of the elseif- or else-block. Its ! structure is identical to that of the if-block-header, except that in case of an ! @code{ELSE} block without a new condition the @code{expr} member should be ! @code{NULL}. This block can itself have its @code{block} member point to the ! next @code{ELSEIF} or @code{ELSE} block if there's a chain of them. ! ! ! @subsection Loops ! ! @code{DO} loops are stored in the tree as @code{gfc_code} nodes with their ! @code{op} set to @code{EXEC_DO} for a @code{DO} loop with iterator variable and ! to @code{EXEC_DO_WHILE} for infinite @code{DO}s and @code{DO WHILE} blocks. ! Their @code{block} member should point to a @code{gfc_code} structure heading ! the code-chain of the loop body; its @code{op} member should be set to ! @code{EXEC_DO} or @code{EXEC_DO_WHILE}, too, respectively. ! ! For @code{DO WHILE} loops, the loop condition is stored on the top ! @code{gfc_code} structure's @code{expr} member; @code{DO} forever loops are ! simply @code{DO WHILE} loops with a constant @code{.TRUE.} loop condition in ! the internal representation. ! ! Similarly, @code{DO} loops with an iterator have instead of the condition their ! @code{ext.iterator} member set to the correct values for the loop iterator ! variable and its range. ! ! ! @subsection @code{SELECT} Statements ! ! A @code{SELECT} block is introduced by a @code{gfc_code} structure with an ! @code{op} member of @code{EXEC_SELECT} and @code{expr} containing the expression ! to evaluate and test. Its @code{block} member starts a list of @code{gfc_code} ! structures linked together by their @code{block} members that stores the various ! @code{CASE} parts. ! ! Each @code{CASE} node has its @code{op} member set to @code{EXEC_SELECT}, too, ! its @code{next} member points to the code-chain to be executed in the current ! case-block, and @code{extx.case_list} contains the case-values this block ! corresponds to. The @code{block} member links to the next case in the list. ! ! ! @c gfc_expr ! @c -------- ! ! @node gfc_expr ! @section @code{gfc_expr} ! @tindex @code{gfc_expr} ! @tindex @code{struct gfc_expr} ! ! Expressions and ``values'', including constants, variable-, array- and ! component-references as well as complex expressions consisting of operators and ! function calls are internally represented as one or a whole tree of ! @code{gfc_expr} objects. The member @code{expr_type} specifies the overall ! type of an expression (for instance, @code{EXPR_CONSTANT} for constants or ! @code{EXPR_VARIABLE} for variable references). The members @code{ts} and ! @code{rank} as well as @code{shape}, which can be @code{NULL}, specify ! the type, rank and, if applicable, shape of the whole expression or expression ! tree of which the current structure is the root. @code{where} is the locus of ! this expression in the source code. ! ! Depending on the flavour of the expression being described by the object ! (that is, the value of its @code{expr_type} member), the corresponding structure ! in the @code{value} union will usually contain additional data describing the ! expression's value in a type-specific manner. The @code{ref} member is used to ! build chains of (array-, component- and substring-) references if the expression ! in question contains such references, see below for details. ! ! ! @subsection Constants ! ! Scalar constants are represented by @code{gfc_expr} nodes with their ! @code{expr_type} set to @code{EXPR_CONSTANT}. The constant's value shall ! already be known at compile-time and is stored in the @code{logical}, ! @code{integer}, @code{real}, @code{complex} or @code{character} struct inside ! @code{value}, depending on the constant's type specification. ! ! ! @subsection Operators ! ! Operator-expressions are expressions that are the result of the execution of ! some operator on one or two operands. The expressions have an @code{expr_type} ! of @code{EXPR_OP}. Their @code{value.op} structure contains additional data. ! ! @code{op1} and optionally @code{op2} if the operator is binary point to the ! two operands, and @code{operator} or @code{uop} describe the operator that ! should be evaluated on these operands, where @code{uop} describes a user-defined ! operator. ! ! ! @subsection Function Calls ! ! If the expression is the return value of a function-call, its @code{expr_type} ! is set to @code{EXPR_FUNCTION}, and @code{symtree} must point to the symtree ! identifying the function to be called. @code{value.function.actual} holds the ! actual arguments given to the function as a linked list of ! @code{gfc_actual_arglist} nodes. ! ! The other members of @code{value.function} describe the function being called ! in more detail, containing a link to the intrinsic symbol or user-defined ! function symbol if the call is to an intrinsic or external function, ! respectively. These values are determined during resolution-phase from the ! structure's @code{symtree} member. ! ! A special case of function calls are ``component calls'' to type-bound ! procedures; those have the @code{expr_type} @code{EXPR_COMPCALL} with ! @code{value.compcall} containing the argument list and the procedure called, ! while @code{symtree} and @code{ref} describe the object on which the procedure ! was called in the same way as a @code{EXPR_VARIABLE} expression would. ! @xref{Type-bound Procedures}. ! ! ! @subsection Array- and Structure-Constructors ! ! Array- and structure-constructors (one could probably call them ``array-'' and ! ``derived-type constants'') are @code{gfc_expr} structures with their ! @code{expr_type} member set to @code{EXPR_ARRAY} or @code{EXPR_STRUCTURE}, ! respectively. For structure constructors, @code{symtree} points to the ! derived-type symbol for the type being constructed. ! ! The values for initializing each array element or structure component are ! stored as linked-list of @code{gfc_constructor} nodes in the ! @code{value.constructor} member. ! ! ! @subsection Null ! ! @code{NULL} is a special value for pointers; it can be of different base types. ! Such a @code{NULL} value is represented in the internal tree by a ! @code{gfc_expr} node with @code{expr_type} @code{EXPR_NULL}. If the base type ! of the @code{NULL} expression is known, it is stored in @code{ts} (that's for ! instance the case for default-initializers of @code{ALLOCATABLE} components), ! but this member can also be set to @code{BT_UNKNOWN} if the information is not ! available (for instance, when the expression is a pointer-initializer ! @code{NULL()}). ! ! ! @subsection Variables and Reference Expressions ! ! Variable references are @code{gfc_expr} structures with their @code{expr_type} ! set to @code{EXPR_VARIABLE}; their @code{symtree} should point to the variable ! that is referenced. ! ! For this type of expression, it's also possible to chain array-, component- ! or substring-references to the original expression to get something like ! @samp{struct%component(2:5)}, where @code{component} is either an array or ! a @code{CHARACTER} member of @code{struct} that is of some derived-type. Such a ! chain of references is achieved by a linked list headed by @code{ref} of the ! @code{gfc_expr} node. For the example above it would be (@samp{==|} is the ! last @code{NULL} pointer): ! ! @smallexample ! EXPR_VARIABLE(struct) ==> REF_COMPONENT(component) ==> REF_ARRAY(2:5) ==| ! @end smallexample ! ! If @code{component} is a string rather than an array, the last element would be ! a @code{REF_SUBSTRING} reference, of course. If the variable itself or some ! component referenced is an array and the expression should reference the whole ! array rather than being followed by an array-element or -section reference, a ! @code{REF_ARRAY} reference must be built as the last element in the chain with ! an array-reference type of @code{AR_FULL}. Consider this example code: ! ! @smallexample ! TYPE :: mytype ! INTEGER :: array(42) ! END TYPE mytype ! ! TYPE(mytype) :: variable ! INTEGER :: local_array(5) ! ! CALL do_something (variable%array, local_array) ! @end smallexample ! ! The @code{gfc_expr} nodes representing the arguments to the @samp{do_something} ! call will have a reference-chain like this: ! ! @smallexample ! EXPR_VARIABLE(variable) ==> REF_COMPONENT(array) ==> REF_ARRAY(FULL) ==| ! EXPR_VARIABLE(local_array) ==> REF_ARRAY(FULL) ==| ! @end smallexample ! ! ! @subsection Constant Substring References ! ! @code{EXPR_SUBSTRING} is a special type of expression that encodes a substring ! reference of a constant string, as in the following code snippet: ! ! @smallexample ! x = "abcde"(1:2) ! @end smallexample ! ! In this case, @code{value.character} contains the full string's data as if it ! was a string constant, but the @code{ref} member is also set and points to a ! substring reference as described in the subsection above. ! ! ! @c --------------------------------------------------------------------- ! @c F2003 OOP ! @c --------------------------------------------------------------------- ! ! @node Object Orientation ! @chapter Internals of Fortran 2003 OOP Features ! ! @menu ! * Type-bound Procedures:: Type-bound procedures. ! @end menu ! ! ! @c Type-bound procedures ! @c --------------------- ! ! @node Type-bound Procedures ! @section Type-bound Procedures ! ! Type-bound procedures are stored in the @code{sym_root} of the namespace ! @code{f2k_derived} associated with the derived-type symbol as @code{gfc_symtree} ! nodes. The name and symbol of these symtrees corresponds to the binding-name ! of the procedure, i.e. the name that is used to call it from the context of an ! object of the derived-type. ! ! In addition, those and only those symtrees representing a type-bound procedure ! have their @code{typebound} member set; @code{typebound} points to a struct of ! type @code{gfc_typebound_proc} containing the additional data needed: The ! binding attributes (like @code{PASS} and @code{NOPASS}, @code{NON_OVERRIDABLE} ! or the access-specifier), the binding's target(s) and, if the current binding ! overrides or extends an inherited binding of the same name, @code{overridden} ! points to this binding's @code{gfc_typebound_proc} structure. ! ! ! @subsection Specific Bindings ! @c -------------------------- ! ! For specific bindings (declared with @code{PROCEDURE}), if they have a ! passed-object argument, the passed-object dummy argument is first saved by its ! name, and later during resolution phase the corresponding argument is looked for ! and its position remembered as @code{pass_arg_num} in @code{gfc_typebound_proc}. ! The binding's target procedure is pointed-to by @code{u.specific}. ! ! At the moment, all type-bound procedure calls are statically dispatched and ! transformed into ordinary procedure calls at resolution time; their actual ! argument list is updated to include at the right position the passed-object ! argument, if applicable, and then a simple procedure call to the binding's ! target procedure is built. To handle dynamic dispatch in the future, this will ! be extended to allow special code generation during the trans-phase to dispatch ! based on the object's dynamic type. ! ! ! @subsection Generic Bindings ! @c ------------------------- ! ! Bindings declared as @code{GENERIC} store the specific bindings they target as ! a linked list using nodes of type @code{gfc_tbp_generic} in @code{u.generic}. ! For each specific target, the parser records its symtree and during resolution ! this symtree is bound to the corresponding @code{gfc_typebound_proc} structure ! of the specific target. ! ! Calls to generic bindings are handled entirely in the resolution-phase, where ! for the actual argument list present the matching specific binding is found ! and the call's target procedure (@code{value.compcall.tbp}) is re-pointed to ! the found specific binding and this call is subsequently handled by the logic ! for specific binding calls. ! ! ! @subsection Calls to Type-bound Procedures ! @c --------------------------------------- ! ! Calls to type-bound procedures are stored in the parse-tree as @code{gfc_expr} ! nodes of type @code{EXPR_COMPCALL}. Their @code{value.compcall.actual} saves ! the actual argument list of the call and @code{value.compcall.tbp} points to the ! @code{gfc_typebound_proc} structure of the binding to be called. The object ! in whose context the procedure was called is saved by combination of ! @code{symtree} and @code{ref}, as if the expression was of type ! @code{EXPR_VARIABLE}. ! ! For code like this: ! @smallexample ! CALL myobj%procedure (arg1, arg2) ! @end smallexample ! @noindent ! the @code{CALL} is represented in the parse-tree as a @code{gfc_code} node of ! type @code{EXEC_COMPCALL}. The @code{expr} member of this node holds an ! expression of type @code{EXPR_COMPCALL} of the same structure as mentioned above ! except that its target procedure is of course a @code{SUBROUTINE} and not a ! @code{FUNCTION}. @c --------------------------------------------------------------------- *************** Versioning - Ulrich Depper} *** 359,371 **** @item @uref{http://people.redhat.com/drepper/dsohowto.pdf, How to Write Shared ! Libraries - Ulrich Depper (see Chapter 3)} @end itemize If one adds a new symbol to a library that should be exported, the new symbol should be mentioned in the map file and a new version node ! defined, e.g. if one adds a new symbols @code{foo} and @code{bar} to libgfortran for the next GCC release, the following should be added to the map file: @smallexample --- 690,702 ---- @item @uref{http://people.redhat.com/drepper/dsohowto.pdf, How to Write Shared ! Libraries - Ulrich Drepper (see Chapter 3)} @end itemize If one adds a new symbol to a library that should be exported, the new symbol should be mentioned in the map file and a new version node ! defined, e.g., if one adds a new symbols @code{foo} and @code{bar} to libgfortran for the next GCC release, the following should be added to the map file: @smallexample diff -Nrcpad gcc-4.3.3/gcc/fortran/gfortran.h gcc-4.4.0/gcc/fortran/gfortran.h *** gcc-4.3.3/gcc/fortran/gfortran.h Sat Jan 10 21:01:14 2009 --- gcc-4.4.0/gcc/fortran/gfortran.h Sat Feb 21 22:25:06 2009 *************** *** 1,5 **** /* gfortran header file ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught --- 1,5 ---- /* gfortran header file ! Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. Contributed by Andy Vaught *************** char *alloca (); *** 78,84 **** #define stringize(x) expand_macro(x) #define expand_macro(x) # x ! /* For a the runtime library, a standard prefix is a requirement to avoid cluttering the namespace with things nobody asked for. It's ugly to look at and a pain to type when you add the prefix by hand, so we hide it behind a macro. */ --- 78,84 ---- #define stringize(x) expand_macro(x) #define expand_macro(x) # x ! /* For the runtime library, a standard prefix is a requirement to avoid cluttering the namespace with things nobody asked for. It's ugly to look at and a pain to type when you add the prefix by hand, so we hide it behind a macro. */ *************** mstring; *** 103,108 **** --- 103,114 ---- /*************************** Enums *****************************/ + /* Used when matching and resolving data I/O transfer statements. */ + + typedef enum + { M_READ, M_WRITE, M_PRINT, M_INQUIRE } + io_kind; + /* The author remains confused to this day about the convention of returning '0' for 'SUCCESS'... or was it the other way around? The following enum makes things much more readable. We also start *************** mstring; *** 110,116 **** typedef enum { SUCCESS = 1, FAILURE } ! try; /* This is returned by gfc_notification_std to know if, given the flags that were given (-std=, -pedantic) we should issue an error, a warning --- 116,122 ---- typedef enum { SUCCESS = 1, FAILURE } ! gfc_try; /* This is returned by gfc_notification_std to know if, given the flags that were given (-std=, -pedantic) we should issue an error, a warning *************** bt; *** 145,151 **** /* Expression node types. */ typedef enum { EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE, ! EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL } expr_t; --- 151,157 ---- /* Expression node types. */ typedef enum { EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE, ! EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL } expr_t; *************** typedef enum *** 204,218 **** ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE, ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF, ST_ELSEWHERE, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO, ! ST_END_FILE, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE, ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, ST_INQUIRE, ST_INTERFACE, ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN, ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND, ! ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WRITE, ! ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_CRITICAL, --- 210,224 ---- ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE, ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF, ST_ELSEWHERE, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO, ! ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE, ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, ST_INQUIRE, ST_INTERFACE, ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN, ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND, ! ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, ! ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_CRITICAL, *************** typedef enum *** 222,228 **** ST_OMP_END_WORKSHARE, ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED, ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS, ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE, ! ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_PROCEDURE, ST_GET_FCN_CHARACTERISTICS, ST_NONE } gfc_statement; --- 228,235 ---- ST_OMP_END_WORKSHARE, ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED, ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS, ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE, ! ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK, ! ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC, ST_GET_FCN_CHARACTERISTICS, ST_NONE } gfc_statement; *************** extern const mstring save_status[]; *** 295,301 **** enum gfc_isym_id { /* GFC_ISYM_NONE is used for intrinsics which will never be seen by ! the backend (eg. KIND). */ GFC_ISYM_NONE = 0, GFC_ISYM_ABORT, GFC_ISYM_ABS, --- 302,308 ---- enum gfc_isym_id { /* GFC_ISYM_NONE is used for intrinsics which will never be seen by ! the backend (e.g. KIND). */ GFC_ISYM_NONE = 0, GFC_ISYM_ABORT, GFC_ISYM_ABS, *************** enum gfc_isym_id *** 347,352 **** --- 354,360 ---- GFC_ISYM_EPSILON, GFC_ISYM_ERF, GFC_ISYM_ERFC, + GFC_ISYM_ERFC_SCALED, GFC_ISYM_ETIME, GFC_ISYM_EXIT, GFC_ISYM_EXP, *************** enum gfc_isym_id *** 379,384 **** --- 387,393 ---- GFC_ISYM_GMTIME, GFC_ISYM_HOSTNM, GFC_ISYM_HUGE, + GFC_ISYM_HYPOT, GFC_ISYM_IACHAR, GFC_ISYM_IAND, GFC_ISYM_IARGC, *************** enum gfc_isym_id *** 408,413 **** --- 417,423 ---- GFC_ISYM_KILL, GFC_ISYM_KIND, GFC_ISYM_LBOUND, + GFC_ISYM_LEADZ, GFC_ISYM_LEN, GFC_ISYM_LEN_TRIM, GFC_ISYM_LGAMMA, *************** enum gfc_isym_id *** 463,468 **** --- 473,479 ---- GFC_ISYM_RESHAPE, GFC_ISYM_RRSPACING, GFC_ISYM_RSHIFT, + GFC_ISYM_SC_KIND, GFC_ISYM_SCALE, GFC_ISYM_SCAN, GFC_ISYM_SECNDS, *************** enum gfc_isym_id *** 493,498 **** --- 504,510 ---- GFC_ISYM_TIME, GFC_ISYM_TIME8, GFC_ISYM_TINY, + GFC_ISYM_TRAILZ, GFC_ISYM_TRANSFER, GFC_ISYM_TRANSPOSE, GFC_ISYM_TRIM, *************** init_local_integer; *** 547,553 **** /* Used for keeping things in balanced binary trees. */ #define BBT_HEADER(self) int priority; struct self *left, *right ! #define NAMED_INTCST(a,b,c) a, typedef enum { ISOFORTRANENV_INVALID = -1, --- 559,565 ---- /* Used for keeping things in balanced binary trees. */ #define BBT_HEADER(self) int priority; struct self *left, *right ! #define NAMED_INTCST(a,b,c,d) a, typedef enum { ISOFORTRANENV_INVALID = -1, *************** typedef enum *** 557,563 **** iso_fortran_env_symbol; #undef NAMED_INTCST ! #define NAMED_INTCST(a,b,c) a, #define NAMED_REALCST(a,b,c) a, #define NAMED_CMPXCST(a,b,c) a, #define NAMED_LOGCST(a,b,c) a, --- 569,575 ---- iso_fortran_env_symbol; #undef NAMED_INTCST ! #define NAMED_INTCST(a,b,c,d) a, #define NAMED_REALCST(a,b,c) a, #define NAMED_CMPXCST(a,b,c) a, #define NAMED_LOGCST(a,b,c) a, *************** typedef struct *** 610,621 **** unsigned allocatable:1, dimension:1, external:1, intrinsic:1, optional:1, pointer:1, target:1, value:1, volatile_:1, dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1, ! implied_index:1, subref_array_pointer:1; ENUM_BITFIELD (save_state) save:2; unsigned data:1, /* Symbol is named in a DATA statement. */ ! protected:1, /* Symbol has been marked as protected. */ use_assoc:1, /* Symbol has been use-associated. */ use_only:1, /* Symbol has been use-associated, with ONLY. */ use_rename:1, /* Symbol has been use-associated and renamed. */ --- 622,633 ---- unsigned allocatable:1, dimension:1, external:1, intrinsic:1, optional:1, pointer:1, target:1, value:1, volatile_:1, dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1, ! implied_index:1, subref_array_pointer:1, proc_pointer:1; ENUM_BITFIELD (save_state) save:2; unsigned data:1, /* Symbol is named in a DATA statement. */ ! is_protected:1, /* Symbol has been marked as protected. */ use_assoc:1, /* Symbol has been use-associated. */ use_only:1, /* Symbol has been use-associated, with ONLY. */ use_rename:1, /* Symbol has been use-associated and renamed. */ *************** typedef struct *** 625,633 **** unsigned function:1, subroutine:1, procedure:1; unsigned generic:1, generic_copy:1; unsigned implicit_type:1; /* Type defined via implicit rules. */ ! unsigned untyped:1; /* No implicit type could be found. */ ! unsigned is_bind_c:1; /* say if is bound to C */ /* These flags are both in the typespec and attribute. The attribute list is what gets read from/written to a module file. The typespec --- 637,646 ---- unsigned function:1, subroutine:1, procedure:1; unsigned generic:1, generic_copy:1; unsigned implicit_type:1; /* Type defined via implicit rules. */ ! unsigned untyped:1; /* No implicit type could be found. */ ! unsigned is_bind_c:1; /* say if is bound to C. */ ! unsigned extension:1; /* extends a derived type. */ /* These flags are both in the typespec and attribute. The attribute list is what gets read from/written to a module file. The typespec *************** typedef struct *** 681,687 **** unsigned cray_pointer:1, cray_pointee:1; /* The symbol is a derived type with allocatable components, pointer ! components or private components, possibly nested. zer_comp is true if the derived type has no component at all. */ unsigned alloc_comp:1, pointer_comp:1, private_comp:1, zero_comp:1; --- 694,700 ---- unsigned cray_pointer:1, cray_pointee:1; /* The symbol is a derived type with allocatable components, pointer ! components or private components, possibly nested. zero_comp is true if the derived type has no component at all. */ unsigned alloc_comp:1, pointer_comp:1, private_comp:1, zero_comp:1; *************** typedef struct *** 691,696 **** --- 704,724 ---- symbol_attribute; + /* We need to store source lines as sequences of multibyte source + characters. We define here a type wide enough to hold any multibyte + source character, just like libcpp does. A 32-bit type is enough. */ + + #if HOST_BITS_PER_INT >= 32 + typedef unsigned int gfc_char_t; + #elif HOST_BITS_PER_LONG >= 32 + typedef unsigned long gfc_char_t; + #elif defined(HAVE_LONG_LONG) && (HOST_BITS_PER_LONGLONG >= 32) + typedef unsigned long long gfc_char_t; + #else + # error "Cannot find an integer type with at least 32 bits" + #endif + + /* The following three structures are used to identify a location in the sources. *************** typedef struct gfc_file *** 713,743 **** typedef struct gfc_linebuf { - #ifdef USE_MAPPED_LOCATION source_location location; - #else - int linenum; - #endif struct gfc_file *file; struct gfc_linebuf *next; int truncated; bool dbg_emitted; ! char line[1]; } gfc_linebuf; #define gfc_linebuf_header_size (offsetof (gfc_linebuf, line)) - #ifdef USE_MAPPED_LOCATION #define gfc_linebuf_linenum(LBUF) (LOCATION_LINE ((LBUF)->location)) - #else - #define gfc_linebuf_linenum(LBUF) ((LBUF)->linenum) - #endif typedef struct { ! char *nextc; gfc_linebuf *lb; } locus; --- 741,763 ---- typedef struct gfc_linebuf { source_location location; struct gfc_file *file; struct gfc_linebuf *next; int truncated; bool dbg_emitted; ! gfc_char_t line[1]; } gfc_linebuf; #define gfc_linebuf_header_size (offsetof (gfc_linebuf, line)) #define gfc_linebuf_linenum(LBUF) (LOCATION_LINE ((LBUF)->location)) typedef struct { ! gfc_char_t *nextc; gfc_linebuf *lb; } locus; *************** typedef struct *** 750,756 **** #endif ! extern int gfc_suppress_error; /* Character length structures hold the expression that gives the --- 770,779 ---- #endif ! /* Suppress error messages or re-enable them. */ ! ! void gfc_push_suppress_errors (void); ! void gfc_pop_suppress_errors (void); /* Character length structures hold the expression that gives the *************** typedef struct gfc_charlen *** 768,780 **** { struct gfc_expr *length; struct gfc_charlen *next; tree backend_decl; int resolved; } gfc_charlen; ! #define gfc_get_charlen() gfc_getmem(sizeof(gfc_charlen)) /* Type specification structure. FIXME: derived and cl could be union??? */ typedef struct --- 791,804 ---- { struct gfc_expr *length; struct gfc_charlen *next; + bool length_from_typespec; /* Length from explicit array ctor typespec? */ tree backend_decl; int resolved; } gfc_charlen; ! #define gfc_get_charlen() XCNEW (gfc_charlen) /* Type specification structure. FIXME: derived and cl could be union??? */ typedef struct *************** typedef struct *** 783,788 **** --- 807,813 ---- int kind; struct gfc_symbol *derived; gfc_charlen *cl; /* For character types only. */ + struct gfc_symbol *interface; /* For PROCEDURE declarations. */ int is_c_interop; int is_iso_c; bt f90_type; *************** typedef struct *** 805,811 **** } gfc_array_spec; ! #define gfc_get_array_spec() gfc_getmem(sizeof(gfc_array_spec)) /* Components of derived types. */ --- 830,836 ---- } gfc_array_spec; ! #define gfc_get_array_spec() XCNEW (gfc_array_spec) /* Components of derived types. */ *************** typedef struct gfc_component *** 814,821 **** const char *name; gfc_typespec ts; ! int pointer, allocatable, dimension; ! gfc_access access; gfc_array_spec *as; tree backend_decl; --- 839,845 ---- const char *name; gfc_typespec ts; ! symbol_attribute attr; gfc_array_spec *as; tree backend_decl; *************** typedef struct gfc_component *** 825,831 **** } gfc_component; ! #define gfc_get_component() gfc_getmem(sizeof(gfc_component)) /* Formal argument lists are lists of symbols. */ typedef struct gfc_formal_arglist --- 849,855 ---- } gfc_component; ! #define gfc_get_component() XCNEW (gfc_component) /* Formal argument lists are lists of symbols. */ typedef struct gfc_formal_arglist *************** typedef struct gfc_formal_arglist *** 837,843 **** } gfc_formal_arglist; ! #define gfc_get_formal_arglist() gfc_getmem(sizeof(gfc_formal_arglist)) /* The gfc_actual_arglist structure is for actual arguments. */ --- 861,867 ---- } gfc_formal_arglist; ! #define gfc_get_formal_arglist() XCNEW (gfc_formal_arglist) /* The gfc_actual_arglist structure is for actual arguments. */ *************** typedef struct gfc_actual_arglist *** 857,863 **** } gfc_actual_arglist; ! #define gfc_get_actual_arglist() gfc_getmem(sizeof(gfc_actual_arglist)) /* Because a symbol can belong to multiple namelists, they must be --- 881,887 ---- } gfc_actual_arglist; ! #define gfc_get_actual_arglist() XCNEW (gfc_actual_arglist) /* Because a symbol can belong to multiple namelists, they must be *************** typedef struct gfc_namelist *** 869,875 **** } gfc_namelist; ! #define gfc_get_namelist() gfc_getmem(sizeof(gfc_namelist)) enum { --- 893,899 ---- } gfc_namelist; ! #define gfc_get_namelist() XCNEW (gfc_namelist) enum { *************** typedef struct gfc_omp_clauses *** 909,915 **** OMP_SCHED_STATIC, OMP_SCHED_DYNAMIC, OMP_SCHED_GUIDED, ! OMP_SCHED_RUNTIME } sched_kind; struct gfc_expr *chunk_size; enum --- 933,940 ---- OMP_SCHED_STATIC, OMP_SCHED_DYNAMIC, OMP_SCHED_GUIDED, ! OMP_SCHED_RUNTIME, ! OMP_SCHED_AUTO } sched_kind; struct gfc_expr *chunk_size; enum *************** typedef struct gfc_omp_clauses *** 917,929 **** OMP_DEFAULT_UNKNOWN, OMP_DEFAULT_NONE, OMP_DEFAULT_PRIVATE, ! OMP_DEFAULT_SHARED } default_sharing; ! bool nowait, ordered; } gfc_omp_clauses; ! #define gfc_get_omp_clauses() gfc_getmem(sizeof(gfc_omp_clauses)) /* The gfc_st_label structure is a doubly linked list attached to a --- 942,956 ---- OMP_DEFAULT_UNKNOWN, OMP_DEFAULT_NONE, OMP_DEFAULT_PRIVATE, ! OMP_DEFAULT_SHARED, ! OMP_DEFAULT_FIRSTPRIVATE } default_sharing; ! int collapse; ! bool nowait, ordered, untied; } gfc_omp_clauses; ! #define gfc_get_omp_clauses() XCNEW (gfc_omp_clauses) /* The gfc_st_label structure is a doubly linked list attached to a *************** typedef struct gfc_interface *** 956,975 **** } gfc_interface; ! #define gfc_get_interface() gfc_getmem(sizeof(gfc_interface)) ! /* User operator nodes. These are like stripped down symbols. */ typedef struct { const char *name; ! gfc_interface *operator; struct gfc_namespace *ns; gfc_access access; } gfc_user_op; /* Symbol nodes. These are important things. They are what the standard refers to as "entities". The possibly multiple names that refer to the same entity are accomplished by a binary tree of --- 983,1052 ---- } gfc_interface; ! #define gfc_get_interface() XCNEW (gfc_interface) /* User operator nodes. These are like stripped down symbols. */ typedef struct { const char *name; ! gfc_interface *op; struct gfc_namespace *ns; gfc_access access; } gfc_user_op; + + /* A list of specific bindings that are associated with a generic spec. */ + typedef struct gfc_tbp_generic + { + /* The parser sets specific_st, upon resolution we look for the corresponding + gfc_typebound_proc and set specific for further use. */ + struct gfc_symtree* specific_st; + struct gfc_typebound_proc* specific; + + struct gfc_tbp_generic* next; + } + gfc_tbp_generic; + + #define gfc_get_tbp_generic() XCNEW (gfc_tbp_generic) + + + /* Data needed for type-bound procedures. */ + typedef struct gfc_typebound_proc + { + locus where; /* Where the PROCEDURE/GENERIC definition was. */ + + union + { + struct gfc_symtree* specific; + gfc_tbp_generic* generic; + } + u; + + gfc_access access; + char* pass_arg; /* Argument-name for PASS. NULL if not specified. */ + + /* The overridden type-bound proc (or GENERIC with this name in the + parent-type) or NULL if non. */ + struct gfc_typebound_proc* overridden; + + /* Once resolved, we use the position of pass_arg in the formal arglist of + the binding-target procedure to identify it. The first argument has + number 1 here, the second 2, and so on. */ + unsigned pass_arg_num; + + unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */ + unsigned non_overridable:1; + unsigned is_generic:1; + unsigned function:1, subroutine:1; + unsigned error:1; /* Ignore it, when an error occurred during resolution. */ + } + gfc_typebound_proc; + + #define gfc_get_typebound_proc() XCNEW (gfc_typebound_proc) + + /* Symbol nodes. These are important things. They are what the standard refers to as "entities". The possibly multiple names that refer to the same entity are accomplished by a binary tree of *************** typedef struct gfc_symbol *** 985,991 **** gfc_typespec ts; symbol_attribute attr; ! /* The interface member points to the formal argument list if the symbol is a function or subroutine name. If the symbol is a generic name, the generic member points to the list of interfaces. */ --- 1062,1068 ---- gfc_typespec ts; symbol_attribute attr; ! /* The formal member points to the formal argument list if the symbol is a function or subroutine name. If the symbol is a generic name, the generic member points to the list of interfaces. */ *************** typedef struct gfc_symbol *** 995,1008 **** gfc_formal_arglist *formal; struct gfc_namespace *formal_ns; struct gfc_expr *value; /* Parameter/Initializer value */ gfc_array_spec *as; struct gfc_symbol *result; /* function result symbol */ gfc_component *components; /* Derived type components */ - struct gfc_symbol *interface; /* For PROCEDURE declarations. */ - /* Defined only for Cray pointees; points to their pointer. */ struct gfc_symbol *cp_pointer; --- 1072,1084 ---- gfc_formal_arglist *formal; struct gfc_namespace *formal_ns; + struct gfc_namespace *f2k_derived; struct gfc_expr *value; /* Parameter/Initializer value */ gfc_array_spec *as; struct gfc_symbol *result; /* function result symbol */ gfc_component *components; /* Derived type components */ /* Defined only for Cray pointees; points to their pointer. */ struct gfc_symbol *cp_pointer; *************** typedef struct gfc_symbol *** 1028,1034 **** the old symbol. */ struct gfc_symbol *old_symbol, *tlink; ! unsigned mark:1, new:1; /* Nonzero if all equivalences associated with this symbol have been processed. */ unsigned equiv_built:1; --- 1104,1110 ---- the old symbol. */ struct gfc_symbol *old_symbol, *tlink; ! unsigned mark:1, gfc_new:1; /* Nonzero if all equivalences associated with this symbol have been processed. */ unsigned equiv_built:1; *************** typedef struct gfc_common_head *** 1068,1074 **** } gfc_common_head; ! #define gfc_get_common_head() gfc_getmem(sizeof(gfc_common_head)) /* A list of all the alternate entry points for a procedure. */ --- 1144,1150 ---- } gfc_common_head; ! #define gfc_get_common_head() XCNEW (gfc_common_head) /* A list of all the alternate entry points for a procedure. */ *************** typedef struct gfc_entry_list *** 1081,1087 **** int id; /* The LABEL_EXPR marking this entry point. */ tree label; ! /* The nest item in the list. */ struct gfc_entry_list *next; } gfc_entry_list; --- 1157,1163 ---- int id; /* The LABEL_EXPR marking this entry point. */ tree label; ! /* The next item in the list. */ struct gfc_entry_list *next; } gfc_entry_list; *************** gfc_entry_list; *** 1089,1094 **** --- 1165,1200 ---- #define gfc_get_entry_list() \ (gfc_entry_list *) gfc_getmem(sizeof(gfc_entry_list)) + /* Lists of rename info for the USE statement. */ + + typedef struct gfc_use_rename + { + char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1]; + struct gfc_use_rename *next; + int found; + gfc_intrinsic_op op; + locus where; + } + gfc_use_rename; + + #define gfc_get_use_rename() XCNEW (gfc_use_rename); + + /* A list of all USE statements in a namespace. */ + + typedef struct gfc_use_list + { + const char *module_name; + int only_flag; + struct gfc_use_rename *rename; + locus where; + /* Next USE statement. */ + struct gfc_use_list *next; + } + gfc_use_list; + + #define gfc_get_use_list() \ + (gfc_use_list *) gfc_getmem(sizeof(gfc_use_list)) + /* Within a namespace, symbols are pointed to by symtree nodes that are linked together in a balanced binary tree. There can be several symtrees pointing to the same symbol node via USE *************** typedef struct gfc_symtree *** 1107,1112 **** --- 1213,1220 ---- } n; + /* Data for type-bound procedures; NULL if no type-bound procedure. */ + gfc_typebound_proc* typebound; } gfc_symtree; *************** typedef struct gfc_dt_list *** 1118,1124 **** } gfc_dt_list; ! #define gfc_get_dt_list() gfc_getmem(sizeof(gfc_dt_list)) /* A list of all derived types. */ extern gfc_dt_list *gfc_derived_types; --- 1226,1232 ---- } gfc_dt_list; ! #define gfc_get_dt_list() XCNEW (gfc_dt_list) /* A list of all derived types. */ extern gfc_dt_list *gfc_derived_types; *************** typedef struct gfc_namespace *** 1135,1145 **** --- 1243,1257 ---- gfc_symtree *uop_root; /* Tree containing all the common blocks. */ gfc_symtree *common_root; + /* Linked list of finalizer procedures. */ + struct gfc_finalizer *finalizers; /* If set_flag[letter] is set, an implicit type has been set for letter. */ int set_flag[GFC_LETTERS]; /* Keeps track of the implicit types associated with the letters. */ gfc_typespec default_type[GFC_LETTERS]; + /* Store the positions of IMPLICIT statements. */ + locus implicit_loc[GFC_LETTERS]; /* If this is a namespace of a procedure, this points to the procedure. */ struct gfc_symbol *proc_name; *************** typedef struct gfc_namespace *** 1153,1159 **** /* Points to the equivalence groups produced by trans_common. */ struct gfc_equiv_list *equiv_lists; ! gfc_interface *operator[GFC_INTRINSIC_OPS]; /* Points to the parent namespace, i.e. the namespace of a module or procedure in which the procedure belonging to this namespace is --- 1265,1271 ---- /* Points to the equivalence groups produced by trans_common. */ struct gfc_equiv_list *equiv_lists; ! gfc_interface *op[GFC_INTRINSIC_OPS]; /* Points to the parent namespace, i.e. the namespace of a module or procedure in which the procedure belonging to this namespace is *************** typedef struct gfc_namespace *** 1173,1179 **** this namespace. */ struct gfc_data *data; ! gfc_charlen *cl_list; int save_all, seen_save, seen_implicit_none; --- 1285,1291 ---- this namespace. */ struct gfc_data *data; ! gfc_charlen *cl_list, *old_cl_list; int save_all, seen_save, seen_implicit_none; *************** typedef struct gfc_namespace *** 1185,1190 **** --- 1297,1305 ---- /* A list of all alternate entry points to this procedure (or NULL). */ gfc_entry_list *entries; + /* A list of USE statements in this namespace. */ + gfc_use_list *use_stmts; + /* Set to 1 if namespace is a BLOCK DATA program unit. */ int is_block_data; *************** typedef struct gfc_array_ref *** 1251,1257 **** } gfc_array_ref; ! #define gfc_get_array_ref() gfc_getmem(sizeof(gfc_array_ref)) /* Component reference nodes. A variable is stored as an expression --- 1366,1372 ---- } gfc_array_ref; ! #define gfc_get_array_ref() XCNEW (gfc_array_ref) /* Component reference nodes. A variable is stored as an expression *************** typedef struct gfc_ref *** 1293,1299 **** } gfc_ref; ! #define gfc_get_ref() gfc_getmem(sizeof(gfc_ref)) /* Structures representing intrinsic symbols and their arguments lists. */ --- 1408,1414 ---- } gfc_ref; ! #define gfc_get_ref() XCNEW (gfc_ref) /* Structures representing intrinsic symbols and their arguments lists. */ *************** gfc_intrinsic_arg; *** 1320,1335 **** typedef union { ! try (*f0)(void); ! try (*f1)(struct gfc_expr *); ! try (*f1m)(gfc_actual_arglist *); ! try (*f2)(struct gfc_expr *, struct gfc_expr *); ! try (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); ! try (*f3ml)(gfc_actual_arglist *); ! try (*f3red)(gfc_actual_arglist *); ! try (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); ! try (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); } gfc_check_f; --- 1435,1450 ---- typedef union { ! gfc_try (*f0)(void); ! gfc_try (*f1)(struct gfc_expr *); ! gfc_try (*f1m)(gfc_actual_arglist *); ! gfc_try (*f2)(struct gfc_expr *, struct gfc_expr *); ! gfc_try (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); ! gfc_try (*f3ml)(gfc_actual_arglist *); ! gfc_try (*f3red)(gfc_actual_arglist *); ! gfc_try (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); ! gfc_try (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); } gfc_check_f; *************** gfc_intrinsic_sym; *** 1402,1412 **** EXPR_FUNCTION Function call, symbol points to function's name EXPR_CONSTANT A scalar constant: Logical, String, Real, Int or Complex EXPR_VARIABLE An Lvalue with a root symbol and possible reference list ! which expresses structure, array and substring refs. EXPR_NULL The NULL pointer value (which also has a basic type). EXPR_SUBSTRING A substring of a constant string EXPR_STRUCTURE A structure constructor ! EXPR_ARRAY An array constructor. */ #include #include --- 1517,1529 ---- EXPR_FUNCTION Function call, symbol points to function's name EXPR_CONSTANT A scalar constant: Logical, String, Real, Int or Complex EXPR_VARIABLE An Lvalue with a root symbol and possible reference list ! which expresses structure, array and substring refs. EXPR_NULL The NULL pointer value (which also has a basic type). EXPR_SUBSTRING A substring of a constant string EXPR_STRUCTURE A structure constructor ! EXPR_ARRAY An array constructor. ! EXPR_COMPCALL Function (or subroutine) call of a procedure pointer ! component or type-bound procedure. */ #include #include *************** typedef struct gfc_expr *** 1421,1427 **** int rank; mpz_t *shape; /* Can be NULL if shape is unknown at compile time */ ! /* Nonnull for functions and structure constructors */ gfc_symtree *symtree; gfc_ref *ref; --- 1538,1545 ---- int rank; mpz_t *shape; /* Can be NULL if shape is unknown at compile time */ ! /* Nonnull for functions and structure constructors, the base object for ! component-calls. */ gfc_symtree *symtree; gfc_ref *ref; *************** typedef struct gfc_expr *** 1458,1463 **** --- 1576,1583 ---- { int logical; + io_kind iokind; + mpz_t integer; mpfr_t real; *************** typedef struct gfc_expr *** 1470,1476 **** struct { ! gfc_intrinsic_op operator; gfc_user_op *uop; struct gfc_expr *op1, *op2; } --- 1590,1596 ---- struct { ! gfc_intrinsic_op op; gfc_user_op *uop; struct gfc_expr *op1, *op2; } *************** typedef struct gfc_expr *** 1487,1494 **** struct { int length; ! char *string; } character; --- 1607,1622 ---- struct { + gfc_actual_arglist* actual; + gfc_typebound_proc* tbp; + const char* name; + } + compcall; + + struct + { int length; ! gfc_char_t *string; } character; *************** gfc_real_info; *** 1558,1563 **** --- 1686,1700 ---- extern gfc_real_info gfc_real_kinds[]; + typedef struct + { + int kind, bit_size; + const char *name; + } + gfc_character_info; + + extern gfc_character_info gfc_character_kinds[]; + /* Equivalence structures. Equivalent lvalues are linked along the *eq pointer, equivalence sets are strung along the *next node. */ *************** typedef struct gfc_equiv *** 1570,1576 **** } gfc_equiv; ! #define gfc_get_equiv() gfc_getmem(sizeof(gfc_equiv)) /* Holds a single equivalence member after processing. */ typedef struct gfc_equiv_info --- 1707,1713 ---- } gfc_equiv; ! #define gfc_get_equiv() XCNEW (gfc_equiv) /* Holds a single equivalence member after processing. */ typedef struct gfc_equiv_info *************** typedef struct gfc_case *** 1622,1628 **** } gfc_case; ! #define gfc_get_case() gfc_getmem(sizeof(gfc_case)) typedef struct --- 1759,1765 ---- } gfc_case; ! #define gfc_get_case() XCNEW (gfc_case) typedef struct *************** typedef struct *** 1631,1637 **** } gfc_iterator; ! #define gfc_get_iterator() gfc_getmem(sizeof(gfc_iterator)) /* Allocation structure for ALLOCATE, DEALLOCATE and NULLIFY statements. */ --- 1768,1774 ---- } gfc_iterator; ! #define gfc_get_iterator() XCNEW (gfc_iterator) /* Allocation structure for ALLOCATE, DEALLOCATE and NULLIFY statements. */ *************** typedef struct gfc_alloc *** 1643,1655 **** } gfc_alloc; ! #define gfc_get_alloc() gfc_getmem(sizeof(gfc_alloc)) typedef struct { gfc_expr *unit, *file, *status, *access, *form, *recl, ! *blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert; gfc_st_label *err; } gfc_open; --- 1780,1793 ---- } gfc_alloc; ! #define gfc_get_alloc() XCNEW (gfc_alloc) typedef struct { gfc_expr *unit, *file, *status, *access, *form, *recl, ! *blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert, ! *decimal, *encoding, *round, *sign, *asynchronous, *id; gfc_st_label *err; } gfc_open; *************** typedef struct *** 1676,1682 **** gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named, *name, *access, *sequential, *direct, *form, *formatted, *unformatted, *recl, *nextrec, *blank, *position, *action, *read, ! *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert, *strm_pos; gfc_st_label *err; --- 1814,1821 ---- gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named, *name, *access, *sequential, *direct, *form, *formatted, *unformatted, *recl, *nextrec, *blank, *position, *action, *read, ! *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert, *strm_pos, ! *asynchronous, *decimal, *encoding, *pending, *round, *sign, *size, *id; gfc_st_label *err; *************** gfc_inquire; *** 1686,1692 **** typedef struct { ! gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg; gfc_symbol *namelist; /* A format_label of `format_asterisk' indicates the "*" format */ --- 1825,1841 ---- typedef struct { ! gfc_expr *unit, *iostat, *iomsg, *id; ! gfc_st_label *err, *end, *eor; ! } ! gfc_wait; ! ! ! typedef struct ! { ! gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg, ! *id, *pos, *asynchronous, *blank, *decimal, *delim, *pad, *round, ! *sign, *extra_comma; gfc_symbol *namelist; /* A format_label of `format_asterisk' indicates the "*" format */ *************** gfc_forall_iterator; *** 1710,1721 **** 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, ! EXEC_OPEN, EXEC_CLOSE, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, --- 1859,1870 ---- typedef enum { EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, ! EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, 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, ! EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, *************** typedef enum *** 1723,1729 **** EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE, EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT, ! EXEC_OMP_END_SINGLE } gfc_exec_op; --- 1872,1878 ---- EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE, EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT, ! EXEC_OMP_END_SINGLE, EXEC_OMP_TASK, EXEC_OMP_TASKWAIT } gfc_exec_op; *************** typedef struct gfc_code *** 1741,1746 **** --- 1890,1896 ---- symbol for the interface definition. const char *sub_name; */ gfc_symbol *resolved_sym; + gfc_intrinsic_sym *resolved_isym; union { *************** typedef struct gfc_code *** 1752,1757 **** --- 1902,1908 ---- gfc_close *close; gfc_filepos *filepos; gfc_inquire *inquire; + gfc_wait *wait; gfc_dt *dt; gfc_forall_iterator *forall_iterator; struct gfc_code *whichloop; *************** typedef struct *** 1819,1825 **** int max_continue_fixed; int max_continue_free; int max_identifier_length; ! int verbose; int warn_aliasing; int warn_ampersand; --- 1970,1976 ---- int max_continue_fixed; int max_continue_free; int max_identifier_length; ! int dump_parse_tree; int warn_aliasing; int warn_ampersand; *************** typedef struct *** 1829,1835 **** --- 1980,1990 ---- int warn_surprising; int warn_tabs; int warn_underflow; + int warn_intrinsic_shadow; + int warn_intrinsics_std; int warn_character_truncation; + int warn_array_temp; + int warn_align_commons; int max_errors; int flag_all_intrinsics; *************** typedef struct *** 1841,1846 **** --- 1996,2002 ---- int flag_second_underscore; int flag_implicit_none; int flag_max_stack_var_size; + int flag_max_array_constructor; int flag_range_check; int flag_pack_derived; int flag_repack_arrays; *************** typedef struct *** 1849,1854 **** --- 2005,2011 ---- int flag_automatic; int flag_backslash; int flag_backtrace; + int flag_check_array_temporaries; int flag_allow_leading_underscore; int flag_dump_core; int flag_external_blas; *************** typedef struct *** 1866,1877 **** int flag_init_logical; int flag_init_character; char flag_init_character_value; int fpe; int warn_std; int allow_std; - int warn_nonstd_intrinsics; int fshort_enums; int convert; int record_marker; --- 2023,2034 ---- int flag_init_logical; int flag_init_character; char flag_init_character_value; + int flag_align_commons; int fpe; int warn_std; int allow_std; int fshort_enums; int convert; int record_marker; *************** typedef struct iterator_stack *** 1910,1915 **** --- 2067,2093 ---- iterator_stack; extern iterator_stack *iter_stack; + + /* Node in the linked list used for storing finalizer procedures. */ + + typedef struct gfc_finalizer + { + struct gfc_finalizer* next; + locus where; /* Where the FINAL declaration occurred. */ + + /* Up to resolution, we want the gfc_symbol, there we lookup the corresponding + symtree and later need only that. This way, we can access and call the + finalizers from every context as they should be "always accessible". I + don't make this a union because we need the information whether proc_sym is + still referenced or not for dereferencing it on deleting a gfc_finalizer + structure. */ + gfc_symbol* proc_sym; + gfc_symtree* proc_tree; + } + gfc_finalizer; + #define gfc_get_finalizer() XCNEW (gfc_finalizer) + + /************************ Function prototypes *************************/ /* decl.c */ *************** bool gfc_in_match_data (void); *** 1919,1925 **** void gfc_scanner_done_1 (void); void gfc_scanner_init_1 (void); ! void gfc_add_include_path (const char *, bool); void gfc_add_intrinsic_modules_path (const char *); void gfc_release_include_path (void); FILE *gfc_open_included_file (const char *, bool, bool); --- 2097,2103 ---- void gfc_scanner_done_1 (void); void gfc_scanner_init_1 (void); ! void gfc_add_include_path (const char *, bool, bool); void gfc_add_intrinsic_modules_path (const char *); void gfc_release_include_path (void); FILE *gfc_open_included_file (const char *, bool, bool); *************** void gfc_advance_line (void); *** 1933,1945 **** int gfc_check_include (void); int gfc_define_undef_line (void); void gfc_skip_comments (void); ! int gfc_next_char_literal (int); ! int gfc_next_char (void); ! int gfc_peek_char (void); void gfc_error_recovery (void); void gfc_gobble_whitespace (void); ! try gfc_new_file (void); const char * gfc_read_orig_filename (const char *, const char **); extern gfc_source_form gfc_current_form; --- 2111,2138 ---- int gfc_check_include (void); int gfc_define_undef_line (void); + int gfc_wide_is_printable (gfc_char_t); + int gfc_wide_is_digit (gfc_char_t); + int gfc_wide_fits_in_byte (gfc_char_t); + gfc_char_t gfc_wide_tolower (gfc_char_t); + gfc_char_t gfc_wide_toupper (gfc_char_t); + size_t gfc_wide_strlen (const gfc_char_t *); + int gfc_wide_strncasecmp (const gfc_char_t *, const char *, size_t); + gfc_char_t *gfc_wide_memset (gfc_char_t *, gfc_char_t, size_t); + char *gfc_widechar_to_char (const gfc_char_t *, int); + gfc_char_t *gfc_char_to_widechar (const char *); + + #define gfc_get_wide_string(n) XCNEWVEC (gfc_char_t, n) + void gfc_skip_comments (void); ! gfc_char_t gfc_next_char_literal (int); ! gfc_char_t gfc_next_char (void); ! char gfc_next_ascii_char (void); ! gfc_char_t gfc_peek_char (void); ! char gfc_peek_ascii_char (void); void gfc_error_recovery (void); void gfc_gobble_whitespace (void); ! gfc_try gfc_new_file (void); const char * gfc_read_orig_filename (const char *, const char **); extern gfc_source_form gfc_current_form; *************** bool gfc_post_options (const char **); *** 1976,1981 **** --- 2169,2175 ---- /* iresolve.c */ const char * gfc_get_string (const char *, ...) ATTRIBUTE_PRINTF_1; + bool gfc_find_sym_in_expr (gfc_symbol *, gfc_expr *); /* error.c */ *************** typedef struct gfc_error_buf *** 1989,1994 **** --- 2183,2190 ---- void gfc_error_init_1 (void); void gfc_buffer_error (int); + const char *gfc_print_wide_char (gfc_char_t); + void gfc_warning (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_warning_now (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); void gfc_clear_warning (void); *************** int gfc_error_check (void); *** 2003,2009 **** int gfc_error_flag_test (void); notification gfc_notification_std (int); ! try gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); /* A general purpose syntax error. */ #define gfc_syntax_error(ST) \ --- 2199,2205 ---- int gfc_error_flag_test (void); notification gfc_notification_std (int); ! gfc_try gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); /* A general purpose syntax error. */ #define gfc_syntax_error(ST) \ *************** void gfc_push_error (gfc_error_buf *); *** 2013,2021 **** void gfc_pop_error (gfc_error_buf *); void gfc_free_error (gfc_error_buf *); - void gfc_status (const char *, ...) ATTRIBUTE_PRINTF_1; - void gfc_status_char (char); - void gfc_get_errors (int *, int *); /* arith.c */ --- 2209,2214 ---- *************** void gfc_arith_init_1 (void); *** 2023,2032 **** void gfc_arith_done_1 (void); gfc_expr *gfc_enum_initializer (gfc_expr *, locus); arith gfc_check_integer_range (mpz_t p, int kind); /* trans-types.c */ ! try gfc_validate_c_kind (gfc_typespec *); ! try gfc_check_any_c_kind (gfc_typespec *); int gfc_validate_kind (bt, int, bool); extern int gfc_index_integer_kind; extern int gfc_default_integer_kind; --- 2216,2225 ---- void gfc_arith_done_1 (void); gfc_expr *gfc_enum_initializer (gfc_expr *, locus); arith gfc_check_integer_range (mpz_t p, int kind); + bool gfc_check_character_range (gfc_char_t, int); /* trans-types.c */ ! gfc_try gfc_check_any_c_kind (gfc_typespec *); int gfc_validate_kind (bt, int, bool); extern int gfc_index_integer_kind; extern int gfc_default_integer_kind; *************** extern int gfc_character_storage_size; *** 2044,2120 **** /* symbol.c */ void gfc_clear_new_implicit (void); ! try gfc_add_new_implicit_range (int, int); ! try gfc_merge_new_implicit (gfc_typespec *); void gfc_set_implicit_none (void); void gfc_check_function_type (gfc_namespace *); bool gfc_is_intrinsic_typename (const char *); gfc_typespec *gfc_get_default_type (gfc_symbol *, gfc_namespace *); ! try gfc_set_default_type (gfc_symbol *, int, gfc_namespace *); ! ! void gfc_set_component_attr (gfc_component *, symbol_attribute *); ! void gfc_get_component_attr (symbol_attribute *, gfc_component *); void gfc_set_sym_referenced (gfc_symbol *); ! try gfc_add_attribute (symbol_attribute *, locus *); ! try gfc_add_allocatable (symbol_attribute *, locus *); ! try gfc_add_dimension (symbol_attribute *, const char *, locus *); ! try gfc_add_external (symbol_attribute *, locus *); ! try gfc_add_intrinsic (symbol_attribute *, locus *); ! try gfc_add_optional (symbol_attribute *, locus *); ! try gfc_add_pointer (symbol_attribute *, locus *); ! try gfc_add_cray_pointer (symbol_attribute *, locus *); ! try gfc_add_cray_pointee (symbol_attribute *, locus *); ! try gfc_mod_pointee_as (gfc_array_spec *); ! try gfc_add_protected (symbol_attribute *, const char *, locus *); ! try gfc_add_result (symbol_attribute *, const char *, locus *); ! try gfc_add_save (symbol_attribute *, const char *, locus *); ! try gfc_add_threadprivate (symbol_attribute *, const char *, locus *); ! try gfc_add_saved_common (symbol_attribute *, locus *); ! try gfc_add_target (symbol_attribute *, locus *); ! try gfc_add_dummy (symbol_attribute *, const char *, locus *); ! try gfc_add_generic (symbol_attribute *, const char *, locus *); ! try gfc_add_common (symbol_attribute *, locus *); ! try gfc_add_in_common (symbol_attribute *, const char *, locus *); ! try gfc_add_in_equivalence (symbol_attribute *, const char *, locus *); ! try gfc_add_data (symbol_attribute *, const char *, locus *); ! try gfc_add_in_namelist (symbol_attribute *, const char *, locus *); ! try gfc_add_sequence (symbol_attribute *, const char *, locus *); ! try gfc_add_elemental (symbol_attribute *, locus *); ! try gfc_add_pure (symbol_attribute *, locus *); ! try gfc_add_recursive (symbol_attribute *, locus *); ! try gfc_add_function (symbol_attribute *, const char *, locus *); ! try gfc_add_subroutine (symbol_attribute *, const char *, locus *); ! try gfc_add_volatile (symbol_attribute *, const char *, locus *); ! try gfc_add_proc (symbol_attribute *attr, const char *name, locus *where); ! try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *); ! try gfc_add_is_bind_c(symbol_attribute *, const char *, locus *, int); ! try gfc_add_value (symbol_attribute *, const char *, locus *); ! try gfc_add_flavor (symbol_attribute *, sym_flavor, const char *, locus *); ! try gfc_add_entry (symbol_attribute *, const char *, locus *); ! try gfc_add_procedure (symbol_attribute *, procedure_type, const char *, locus *); ! try gfc_add_intent (symbol_attribute *, sym_intent, locus *); ! try gfc_add_explicit_interface (gfc_symbol *, ifsrc, gfc_formal_arglist *, locus *); ! try gfc_add_type (gfc_symbol *, gfc_typespec *, locus *); void gfc_clear_attr (symbol_attribute *); ! try gfc_missing_attr (symbol_attribute *, locus *); ! try gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *); ! try gfc_add_component (gfc_symbol *, const char *, gfc_component **); gfc_symbol *gfc_use_derived (gfc_symbol *); gfc_symtree *gfc_use_derived_tree (gfc_symtree *); ! gfc_component *gfc_find_component (gfc_symbol *, const char *); gfc_st_label *gfc_get_st_label (int); void gfc_free_st_label (gfc_st_label *); void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *); ! try gfc_reference_st_label (gfc_st_label *, gfc_sl_type); gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *); --- 2237,2312 ---- /* symbol.c */ void gfc_clear_new_implicit (void); ! gfc_try gfc_add_new_implicit_range (int, int); ! gfc_try gfc_merge_new_implicit (gfc_typespec *); void gfc_set_implicit_none (void); void gfc_check_function_type (gfc_namespace *); bool gfc_is_intrinsic_typename (const char *); gfc_typespec *gfc_get_default_type (gfc_symbol *, gfc_namespace *); ! gfc_try gfc_set_default_type (gfc_symbol *, int, gfc_namespace *); void gfc_set_sym_referenced (gfc_symbol *); ! gfc_try gfc_add_attribute (symbol_attribute *, locus *); ! gfc_try gfc_add_allocatable (symbol_attribute *, locus *); ! gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_external (symbol_attribute *, locus *); ! gfc_try gfc_add_intrinsic (symbol_attribute *, locus *); ! gfc_try gfc_add_optional (symbol_attribute *, locus *); ! gfc_try gfc_add_pointer (symbol_attribute *, locus *); ! gfc_try gfc_add_cray_pointer (symbol_attribute *, locus *); ! gfc_try gfc_add_cray_pointee (symbol_attribute *, locus *); ! gfc_try gfc_mod_pointee_as (gfc_array_spec *); ! gfc_try gfc_add_protected (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_result (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_save (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_threadprivate (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_saved_common (symbol_attribute *, locus *); ! gfc_try gfc_add_target (symbol_attribute *, locus *); ! gfc_try gfc_add_dummy (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_generic (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_common (symbol_attribute *, locus *); ! gfc_try gfc_add_in_common (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_in_equivalence (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_data (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_in_namelist (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_sequence (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_elemental (symbol_attribute *, locus *); ! gfc_try gfc_add_pure (symbol_attribute *, locus *); ! gfc_try gfc_add_recursive (symbol_attribute *, locus *); ! gfc_try gfc_add_function (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_subroutine (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_volatile (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_proc (symbol_attribute *attr, const char *name, locus *where); ! gfc_try gfc_add_abstract (symbol_attribute* attr, locus* where); ! gfc_try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *); ! gfc_try gfc_add_is_bind_c (symbol_attribute *, const char *, locus *, int); ! gfc_try gfc_add_extension (symbol_attribute *, locus *); ! gfc_try gfc_add_value (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_flavor (symbol_attribute *, sym_flavor, const char *, locus *); ! gfc_try gfc_add_entry (symbol_attribute *, const char *, locus *); ! gfc_try gfc_add_procedure (symbol_attribute *, procedure_type, const char *, locus *); ! gfc_try gfc_add_intent (symbol_attribute *, sym_intent, locus *); ! gfc_try gfc_add_explicit_interface (gfc_symbol *, ifsrc, gfc_formal_arglist *, locus *); ! gfc_try gfc_add_type (gfc_symbol *, gfc_typespec *, locus *); void gfc_clear_attr (symbol_attribute *); ! gfc_try gfc_missing_attr (symbol_attribute *, locus *); ! gfc_try gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *); ! gfc_try gfc_add_component (gfc_symbol *, const char *, gfc_component **); gfc_symbol *gfc_use_derived (gfc_symbol *); gfc_symtree *gfc_use_derived_tree (gfc_symtree *); ! gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool); gfc_st_label *gfc_get_st_label (int); void gfc_free_st_label (gfc_st_label *); void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *); ! gfc_try gfc_reference_st_label (gfc_st_label *, gfc_sl_type); gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *); *************** gfc_symbol *gfc_new_symbol (const char * *** 2130,2140 **** int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **); int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **); int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **); ! try verify_c_interop (gfc_typespec *, const char *name, locus *where); ! try verify_c_interop_param (gfc_symbol *); ! try verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *); ! try verify_bind_c_derived_type (gfc_symbol *); ! try verify_com_block_vars_c_interop (gfc_common_head *); void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, const char *); gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, char *, int); int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **); --- 2322,2332 ---- int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **); int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **); int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **); ! gfc_try verify_c_interop (gfc_typespec *); ! gfc_try verify_c_interop_param (gfc_symbol *); ! gfc_try verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *); ! gfc_try verify_bind_c_derived_type (gfc_symbol *); ! gfc_try verify_com_block_vars_c_interop (gfc_common_head *); void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, const char *); gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, char *, int); int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **); *************** int gfc_symbols_could_alias (gfc_symbol *** 2146,2151 **** --- 2338,2344 ---- void gfc_undo_symbols (void); void gfc_commit_symbols (void); void gfc_commit_symbol (gfc_symbol *); + void gfc_free_charlen (gfc_charlen *, gfc_charlen *); void gfc_free_namespace (gfc_namespace *); void gfc_symbol_init_2 (void); *************** void gfc_symbol_state (void); *** 2161,2168 **** --- 2354,2368 ---- gfc_gsymbol *gfc_get_gsymbol (const char *); gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); + gfc_symbol* gfc_get_derived_super_type (gfc_symbol*); + gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool); + void copy_formal_args (gfc_symbol *dest, gfc_symbol *src); + void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */ + + gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus); + /* intrinsic.c */ extern int gfc_init_expr; *************** void gfc_intrinsic_done_1 (void); *** 2177,2187 **** char gfc_type_letter (bt); gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *); ! try gfc_convert_type (gfc_expr *, gfc_typespec *, int); ! try gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int); int gfc_generic_intrinsic (const char *); int gfc_specific_intrinsic (const char *); ! int gfc_intrinsic_name (const char *, int); int gfc_intrinsic_actual_ok (const char *, const bool); gfc_intrinsic_sym *gfc_find_function (const char *); gfc_intrinsic_sym *gfc_find_subroutine (const char *); --- 2377,2388 ---- char gfc_type_letter (bt); gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *); ! gfc_try gfc_convert_type (gfc_expr *, gfc_typespec *, int); ! gfc_try gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int); ! gfc_try gfc_convert_chartype (gfc_expr *, gfc_typespec *); int gfc_generic_intrinsic (const char *); int gfc_specific_intrinsic (const char *); ! bool gfc_is_intrinsic (gfc_symbol*, int, locus); int gfc_intrinsic_actual_ok (const char *, const bool); gfc_intrinsic_sym *gfc_find_function (const char *); gfc_intrinsic_sym *gfc_find_subroutine (const char *); *************** gfc_intrinsic_sym *gfc_find_subroutine ( *** 2189,2194 **** --- 2390,2399 ---- match gfc_intrinsic_func_interface (gfc_expr *, int); match gfc_intrinsic_sub_interface (gfc_code *, int); + void gfc_warn_intrinsic_shadow (const gfc_symbol*, bool, bool); + gfc_try gfc_check_intrinsic_standard (const gfc_intrinsic_sym*, const char**, + bool, locus); + /* match.c -- FIXME */ void gfc_free_iterator (gfc_iterator *, int); void gfc_free_forall_iterator (gfc_forall_iterator *); *************** gfc_expr *gfc_build_conversion (gfc_expr *** 2219,2225 **** void gfc_free_ref_list (gfc_ref *); void gfc_type_convert_binary (gfc_expr *); int gfc_is_constant_expr (gfc_expr *); ! try gfc_simplify_expr (gfc_expr *, int); int gfc_has_vector_index (gfc_expr *); gfc_expr *gfc_get_expr (void); --- 2424,2430 ---- void gfc_free_ref_list (gfc_ref *); void gfc_type_convert_binary (gfc_expr *); int gfc_is_constant_expr (gfc_expr *); ! gfc_try gfc_simplify_expr (gfc_expr *, int); int gfc_has_vector_index (gfc_expr *); gfc_expr *gfc_get_expr (void); *************** gfc_expr *gfc_logical_expr (int, locus * *** 2230,2245 **** mpz_t *gfc_copy_shape (mpz_t *, int); mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *); gfc_expr *gfc_copy_expr (gfc_expr *); ! try gfc_specification_expr (gfc_expr *); int gfc_numeric_ts (gfc_typespec *); int gfc_kind_max (gfc_expr *, gfc_expr *); ! try gfc_check_conformance (const char *, gfc_expr *, gfc_expr *); ! try gfc_check_assign (gfc_expr *, gfc_expr *, int); ! try gfc_check_pointer_assign (gfc_expr *, gfc_expr *); ! try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *); gfc_expr *gfc_default_initializer (gfc_typespec *); gfc_expr *gfc_get_variable_expr (gfc_symtree *); --- 2435,2451 ---- mpz_t *gfc_copy_shape (mpz_t *, int); mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *); gfc_expr *gfc_copy_expr (gfc_expr *); + gfc_ref* gfc_copy_ref (gfc_ref*); ! gfc_try gfc_specification_expr (gfc_expr *); int gfc_numeric_ts (gfc_typespec *); int gfc_kind_max (gfc_expr *, gfc_expr *); ! gfc_try gfc_check_conformance (const char *, gfc_expr *, gfc_expr *); ! gfc_try gfc_check_assign (gfc_expr *, gfc_expr *, int); ! gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *); ! gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *); gfc_expr *gfc_default_initializer (gfc_typespec *); gfc_expr *gfc_get_variable_expr (gfc_symtree *); *************** bool gfc_traverse_expr (gfc_expr *, gfc_ *** 2248,2253 **** --- 2454,2461 ---- bool (*)(gfc_expr *, gfc_symbol *, int*), int); void gfc_expr_set_symbols_referenced (gfc_expr *); + gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool); + void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *); /* st.c */ extern gfc_code new_st; *************** void gfc_free_statement (gfc_code *); *** 2259,2274 **** void gfc_free_statements (gfc_code *); /* resolve.c */ ! try gfc_resolve_expr (gfc_expr *); void gfc_resolve (gfc_namespace *); void gfc_resolve_blocks (gfc_code *, gfc_namespace *); int gfc_impure_variable (gfc_symbol *); int gfc_pure (gfc_symbol *); int gfc_elemental (gfc_symbol *); ! try gfc_resolve_iterator (gfc_iterator *, bool); ! try find_forall_index (gfc_expr *, gfc_symbol *, int); ! try gfc_resolve_index (gfc_expr *, int); ! try gfc_resolve_dim_arg (gfc_expr *); int gfc_is_formal_arg (void); void gfc_resolve_substring_charlen (gfc_expr *); match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *); --- 2467,2482 ---- void gfc_free_statements (gfc_code *); /* resolve.c */ ! gfc_try gfc_resolve_expr (gfc_expr *); void gfc_resolve (gfc_namespace *); void gfc_resolve_blocks (gfc_code *, gfc_namespace *); int gfc_impure_variable (gfc_symbol *); int gfc_pure (gfc_symbol *); int gfc_elemental (gfc_symbol *); ! gfc_try gfc_resolve_iterator (gfc_iterator *, bool); ! gfc_try find_forall_index (gfc_expr *, gfc_symbol *, int); ! gfc_try gfc_resolve_index (gfc_expr *, int); ! gfc_try gfc_resolve_dim_arg (gfc_expr *); int gfc_is_formal_arg (void); void gfc_resolve_substring_charlen (gfc_expr *); match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *); *************** match gfc_iso_c_sub_interface(gfc_code * *** 2278,2286 **** void gfc_free_array_spec (gfc_array_spec *); gfc_array_ref *gfc_copy_array_ref (gfc_array_ref *); ! try gfc_set_array_spec (gfc_symbol *, gfc_array_spec *, locus *); gfc_array_spec *gfc_copy_array_spec (gfc_array_spec *); ! try gfc_resolve_array_spec (gfc_array_spec *, int); int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *); --- 2486,2494 ---- void gfc_free_array_spec (gfc_array_spec *); gfc_array_ref *gfc_copy_array_ref (gfc_array_ref *); ! gfc_try gfc_set_array_spec (gfc_symbol *, gfc_array_spec *, locus *); gfc_array_spec *gfc_copy_array_spec (gfc_array_spec *); ! gfc_try gfc_resolve_array_spec (gfc_array_spec *, int); int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *); *************** gfc_expr *gfc_start_constructor (bt, int *** 2288,2353 **** void gfc_append_constructor (gfc_expr *, gfc_expr *); void gfc_free_constructor (gfc_constructor *); void gfc_simplify_iterator_var (gfc_expr *); ! 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 *); ! try gfc_check_constructor (gfc_expr *, try (*)(gfc_expr *)); gfc_constructor *gfc_copy_constructor (gfc_constructor *); gfc_expr *gfc_get_array_element (gfc_expr *, int); ! try gfc_array_size (gfc_expr *, mpz_t *); ! try gfc_array_dimen_size (gfc_expr *, int, mpz_t *); ! try gfc_array_ref_shape (gfc_array_ref *, mpz_t *); gfc_array_ref *gfc_find_array_ref (gfc_expr *); void gfc_insert_constructor (gfc_expr *, gfc_constructor *); gfc_constructor *gfc_get_constructor (void); tree gfc_conv_array_initializer (tree type, gfc_expr *); ! try spec_size (gfc_array_spec *, mpz_t *); ! try spec_dimen_size (gfc_array_spec *, int, mpz_t *); int gfc_is_compile_time_shape (gfc_array_spec *); /* interface.c -- FIXME: some of these should be in symbol.c */ void gfc_free_interface (gfc_interface *); int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *); int gfc_compare_types (gfc_typespec *, gfc_typespec *); void gfc_check_interfaces (gfc_namespace *); void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); gfc_symbol *gfc_search_interface (gfc_interface *, int, gfc_actual_arglist **); ! try gfc_extend_expr (gfc_expr *); void gfc_free_formal_arglist (gfc_formal_arglist *); ! try gfc_extend_assign (gfc_code *, gfc_namespace *); ! try gfc_add_interface (gfc_symbol *); gfc_interface *gfc_current_interface_head (void); void gfc_set_current_interface_head (gfc_interface *); /* io.c */ extern gfc_st_label format_asterisk; void gfc_free_open (gfc_open *); ! try gfc_resolve_open (gfc_open *); void gfc_free_close (gfc_close *); ! try gfc_resolve_close (gfc_close *); void gfc_free_filepos (gfc_filepos *); ! try gfc_resolve_filepos (gfc_filepos *); void gfc_free_inquire (gfc_inquire *); ! try gfc_resolve_inquire (gfc_inquire *); void gfc_free_dt (gfc_dt *); ! try gfc_resolve_dt (gfc_dt *); /* module.c */ void gfc_module_init_2 (void); void gfc_module_done_2 (void); void gfc_dump_module (const char *, int); bool gfc_check_access (gfc_access, gfc_access); /* primary.c */ symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *); symbol_attribute gfc_expr_attr (gfc_expr *); match gfc_match_rvalue (gfc_expr **); /* trans.c */ void gfc_generate_code (gfc_namespace *); --- 2496,2572 ---- void gfc_append_constructor (gfc_expr *, gfc_expr *); void gfc_free_constructor (gfc_constructor *); void gfc_simplify_iterator_var (gfc_expr *); ! gfc_try gfc_expand_constructor (gfc_expr *); int gfc_constant_ac (gfc_expr *); int gfc_expanded_ac (gfc_expr *); ! gfc_try gfc_resolve_character_array_constructor (gfc_expr *); ! gfc_try gfc_resolve_array_constructor (gfc_expr *); ! gfc_try gfc_check_constructor_type (gfc_expr *); ! gfc_try gfc_check_iter_variable (gfc_expr *); ! gfc_try gfc_check_constructor (gfc_expr *, gfc_try (*)(gfc_expr *)); gfc_constructor *gfc_copy_constructor (gfc_constructor *); gfc_expr *gfc_get_array_element (gfc_expr *, int); ! gfc_try gfc_array_size (gfc_expr *, mpz_t *); ! gfc_try gfc_array_dimen_size (gfc_expr *, int, mpz_t *); ! gfc_try gfc_array_ref_shape (gfc_array_ref *, mpz_t *); gfc_array_ref *gfc_find_array_ref (gfc_expr *); void gfc_insert_constructor (gfc_expr *, gfc_constructor *); gfc_constructor *gfc_get_constructor (void); tree gfc_conv_array_initializer (tree type, gfc_expr *); ! gfc_try spec_size (gfc_array_spec *, mpz_t *); ! gfc_try spec_dimen_size (gfc_array_spec *, int, mpz_t *); int gfc_is_compile_time_shape (gfc_array_spec *); + gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *); + + /* interface.c -- FIXME: some of these should be in symbol.c */ void gfc_free_interface (gfc_interface *); int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *); int gfc_compare_types (gfc_typespec *, gfc_typespec *); + int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int); void gfc_check_interfaces (gfc_namespace *); void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); gfc_symbol *gfc_search_interface (gfc_interface *, int, gfc_actual_arglist **); ! gfc_try gfc_extend_expr (gfc_expr *); void gfc_free_formal_arglist (gfc_formal_arglist *); ! gfc_try gfc_extend_assign (gfc_code *, gfc_namespace *); ! gfc_try gfc_add_interface (gfc_symbol *); gfc_interface *gfc_current_interface_head (void); void gfc_set_current_interface_head (gfc_interface *); + gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*); + bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*); /* io.c */ extern gfc_st_label format_asterisk; void gfc_free_open (gfc_open *); ! gfc_try gfc_resolve_open (gfc_open *); void gfc_free_close (gfc_close *); ! gfc_try gfc_resolve_close (gfc_close *); void gfc_free_filepos (gfc_filepos *); ! gfc_try gfc_resolve_filepos (gfc_filepos *); void gfc_free_inquire (gfc_inquire *); ! gfc_try gfc_resolve_inquire (gfc_inquire *); void gfc_free_dt (gfc_dt *); ! gfc_try gfc_resolve_dt (gfc_dt *); ! void gfc_free_wait (gfc_wait *); ! gfc_try gfc_resolve_wait (gfc_wait *); /* module.c */ void gfc_module_init_2 (void); void gfc_module_done_2 (void); void gfc_dump_module (const char *, int); bool gfc_check_access (gfc_access, gfc_access); + void gfc_free_use_stmts (gfc_use_list *); /* primary.c */ symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *); symbol_attribute gfc_expr_attr (gfc_expr *); match gfc_match_rvalue (gfc_expr **); + match gfc_match_varspec (gfc_expr*, int, bool); + int gfc_check_digit (char, int); /* trans.c */ void gfc_generate_code (gfc_namespace *); *************** void gfc_insert_bbt (void *, void *, com *** 2359,2386 **** void gfc_delete_bbt (void *, void *, compare_fn); /* dump-parse-tree.c */ ! void gfc_show_actual_arglist (gfc_actual_arglist *); ! void gfc_show_array_ref (gfc_array_ref *); ! void gfc_show_array_spec (gfc_array_spec *); ! void gfc_show_attr (symbol_attribute *); ! void gfc_show_code (int, gfc_code *); ! void gfc_show_components (gfc_symbol *); ! void gfc_show_constructor (gfc_constructor *); ! void gfc_show_equiv (gfc_equiv *); ! void gfc_show_expr (gfc_expr *); ! void gfc_show_expr_n (const char *, gfc_expr *); ! void gfc_show_namelist (gfc_namelist *); ! void gfc_show_namespace (gfc_namespace *); ! void gfc_show_ref (gfc_ref *); ! void gfc_show_symbol (gfc_symbol *); ! void gfc_show_symbol_n (const char *, gfc_symbol *); ! void gfc_show_typespec (gfc_typespec *); /* parse.c */ ! try gfc_parse_file (void); void gfc_global_used (gfc_gsymbol *, locus *); /* dependency.c */ int gfc_dep_compare_expr (gfc_expr *, gfc_expr *); #endif /* GCC_GFORTRAN_H */ --- 2578,2594 ---- void gfc_delete_bbt (void *, void *, compare_fn); /* dump-parse-tree.c */ ! void gfc_dump_parse_tree (gfc_namespace *, FILE *); /* parse.c */ ! gfc_try gfc_parse_file (void); void gfc_global_used (gfc_gsymbol *, locus *); /* dependency.c */ int gfc_dep_compare_expr (gfc_expr *, gfc_expr *); + int gfc_is_data_pointer (gfc_expr *); + + /* check.c */ + gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*); #endif /* GCC_GFORTRAN_H */ diff -Nrcpad gcc-4.3.3/gcc/fortran/gfortran.info gcc-4.4.0/gcc/fortran/gfortran.info *** gcc-4.3.3/gcc/fortran/gfortran.info Sat Jan 24 11:53:16 2009 --- gcc-4.4.0/gcc/fortran/gfortran.info Tue Apr 21 09:55:58 2009 *************** *** 1,15 **** This is doc/gfortran.info, produced by makeinfo version 4.12 from ! /abuild/rguenther/tmp/gcc-4.3.3/gcc-4.3.3/gcc/fortran/gfortran.texi. ! Copyright (C) 1999-2007 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document ! under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with the ! Invariant Sections being "GNU General Public License" and "Funding Free ! Software", the Front-Cover texts being (a) (see below), and with the ! Back-Cover Texts being (b) (see below). A copy of the license is ! included in the section entitled "GNU Free Documentation License". (a) The FSF's Front-Cover Text is: --- 1,15 ---- This is doc/gfortran.info, produced by makeinfo version 4.12 from ! /usr/src/gcc-4.4.0/gcc-4.4.0/gcc/fortran/gfortran.texi. ! Copyright (C) 1999-2008 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document ! under the terms of the GNU Free Documentation License, Version 1.2 or any later version published by the Free Software Foundation; with the ! Invariant Sections being "Funding Free Software", the Front-Cover Texts ! being (a) (see below), and with the Back-Cover Texts being (b) (see ! below). A copy of the license is included in the section entitled "GNU ! Free Documentation License". (a) The FSF's Front-Cover Text is: *************** compiler, (`gfortran'). *** 31,45 **** Published by the Free Software Foundation 51 Franklin Street, Fifth Floor Boston, MA 02110-1301 USA ! Copyright (C) 1999-2007 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document ! under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with the ! Invariant Sections being "GNU General Public License" and "Funding Free ! Software", the Front-Cover texts being (a) (see below), and with the ! Back-Cover Texts being (b) (see below). A copy of the license is ! included in the section entitled "GNU Free Documentation License". (a) The FSF's Front-Cover Text is: --- 31,45 ---- Published by the Free Software Foundation 51 Franklin Street, Fifth Floor Boston, MA 02110-1301 USA ! Copyright (C) 1999-2008 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document ! under the terms of the GNU Free Documentation License, Version 1.2 or any later version published by the Free Software Foundation; with the ! Invariant Sections being "Funding Free Software", the Front-Cover Texts ! being (a) (see below), and with the Back-Cover Texts being (b) (see ! below). A copy of the license is included in the section entitled "GNU ! Free Documentation License". (a) The FSF's Front-Cover Text is: *************** Part I: Invoking GNU Fortran *** 70,76 **** * Runtime:: Influencing runtime behavior with environment variables. Part II: Language Reference ! * Fortran 2003 status:: Fortran 2003 features supported by GNU Fortran. * Extensions:: Language extensions implemented by GNU Fortran. * Intrinsic Procedures:: Intrinsic procedures supported by GNU Fortran. * Intrinsic Modules:: Intrinsic modules supported by GNU Fortran. --- 70,77 ---- * Runtime:: Influencing runtime behavior with environment variables. Part II: Language Reference ! * Fortran 2003 and 2008 status:: Fortran 2003 and 2008 features supported by GNU Fortran. ! * Compiler Characteristics:: KIND type parameters supported. * Extensions:: Language extensions implemented by GNU Fortran. * Intrinsic Procedures:: Intrinsic procedures supported by GNU Fortran. * Intrinsic Modules:: Intrinsic modules supported by GNU Fortran. *************** Part II: Language Reference *** 79,85 **** * Copying:: GNU General Public License says how you can copy and share GNU Fortran. * GNU Free Documentation License:: ! How you can copy and share this manual. * Funding:: How to help assure continued work for free software. * Option Index:: Index of command line options * Keyword Index:: Index of concepts --- 80,86 ---- * Copying:: GNU General Public License says how you can copy and share GNU Fortran. * GNU Free Documentation License:: ! How you can copy and share this manual. * Funding:: How to help assure continued work for free software. * Option Index:: Index of command line options * Keyword Index:: Index of concepts *************** is the command you'll use to invoke the *** 101,107 **** * Preprocessing and conditional compilation:: The Fortran preprocessor * GNU Fortran and G77:: Why we chose to start from scratch. * Project Status:: Status of GNU Fortran, roadmap, proposed extensions. ! * Standards:: Standards supported by GNU Fortran.  File: gfortran.info, Node: About GNU Fortran, Next: GNU Fortran and GCC, Up: Introduction --- 102,108 ---- * Preprocessing and conditional compilation:: The Fortran preprocessor * GNU Fortran and G77:: Why we chose to start from scratch. * Project Status:: Status of GNU Fortran, roadmap, proposed extensions. ! * Standards:: Standards supported by GNU Fortran.  File: gfortran.info, Node: About GNU Fortran, Next: GNU Fortran and GCC, Up: Introduction *************** remains to be done. *** 117,124 **** expect from any decent compiler: * Read a user's program, stored in a file and containing ! instructions written in Fortran 77, Fortran 90, Fortran 95 or ! Fortran 2003. This file contains "source code". * Translate the user's program into instructions a computer can carry out more quickly than it takes to translate the instructions --- 118,125 ---- expect from any decent compiler: * Read a user's program, stored in a file and containing ! instructions written in Fortran 77, Fortran 90, Fortran 95, ! Fortran 2003 or Fortran 2008. This file contains "source code". * Translate the user's program into instructions a computer can carry out more quickly than it takes to translate the instructions *************** expect from any decent compiler: *** 126,140 **** "machine code", code designed to be efficiently translated and processed by a machine such as your computer. Humans usually aren't as good writing machine code as they are at writing Fortran ! (or C++, Ada, or Java), because is easy to make tiny mistakes writing machine code. * Provide the user with information about the reasons why the compiler is unable to create a binary from the source code. ! Usually this will be the case if the source code is flawed. When ! writing Fortran, it is easy to make big mistakes. The Fortran 90 ! requires that the compiler can point out mistakes to the user. An ! incorrect usage of the language causes an "error message". The compiler will also attempt to diagnose cases where the user's program contains a correct usage of the language, but instructs --- 127,141 ---- "machine code", code designed to be efficiently translated and processed by a machine such as your computer. Humans usually aren't as good writing machine code as they are at writing Fortran ! (or C++, Ada, or Java), because it is easy to make tiny mistakes writing machine code. * Provide the user with information about the reasons why the compiler is unable to create a binary from the source code. ! Usually this will be the case if the source code is flawed. The ! Fortran 90 standard requires that the compiler can point out ! mistakes to the user. An incorrect usage of the language causes ! an "error message". The compiler will also attempt to diagnose cases where the user's program contains a correct usage of the language, but instructs *************** the relevant compiler front-end program *** 205,222 **** each file in the source code, and then calls the assembler and linker as appropriate to produce the compiled output. In a copy of GCC which has been compiled with Fortran language support enabled, `gcc' will ! recognize files with `.f', `.for', `.ftn', `.f90', `.f95', and `.f03' ! extensions as Fortran source code, and compile it accordingly. A `gfortran' driver program is also provided, which is identical to `gcc' except that it automatically links the Fortran runtime libraries into the compiled program. Source files with `.f', `.for', `.fpp', `.ftn', `.F', `.FOR', `.FPP', and `.FTN' extensions are treated as fixed form. Source files ! with `.f90', `.f95', `.f03', `.F90', `.F95', and `.F03' extensions are ! treated as free form. The capitalized versions of either form are run ! through preprocessing. Source files with the lower case `.fpp' ! extension are also run through preprocessing. This manual specifically documents the Fortran front end, which handles the programming language's syntax and semantics. The aspects --- 206,223 ---- each file in the source code, and then calls the assembler and linker as appropriate to produce the compiled output. In a copy of GCC which has been compiled with Fortran language support enabled, `gcc' will ! recognize files with `.f', `.for', `.ftn', `.f90', `.f95', `.f03' and ! `.f08' extensions as Fortran source code, and compile it accordingly. A `gfortran' driver program is also provided, which is identical to `gcc' except that it automatically links the Fortran runtime libraries into the compiled program. Source files with `.f', `.for', `.fpp', `.ftn', `.F', `.FOR', `.FPP', and `.FTN' extensions are treated as fixed form. Source files ! with `.f90', `.f95', `.f03', `.f08', `.F90', `.F95', `.F03' and `.F08' ! extensions are treated as free form. The capitalized versions of ! either form are run through preprocessing. Source files with the lower ! case `.fpp' extension are also run through preprocessing. This manual specifically documents the Fortran front end, which handles the programming language's syntax and semantics. The aspects *************** code through a C preprocessor (CPP; some *** 236,251 **** preprocessor, FPP) to allow for conditional compilation. In the case of GNU Fortran, this is the GNU C Preprocessor in the traditional mode. On systems with case-preserving file names, the preprocessor is ! automatically invoked if the file extension is `.F', `.FOR', `.FTN', ! `.F90', `.F95' or `.F03'; otherwise use for fixed-format code the option ! `-x f77-cpp-input' and for free-format code `-x f95-cpp-input'. ! Invocation of the preprocessor can be suppressed using `-x f77' or `-x ! f95'. ! If the GNU Fortran invoked the preprocessor, `__GFORTRAN__' is ! defined and `__GNUC__', `__GNUC_MINOR__' and `__GNUC_PATCHLEVEL__' can ! be used to determine the version of the compiler. See *note Overview: ! (cpp)Top. for details. While CPP is the de-facto standard for preprocessing Fortran code, Part 3 of the Fortran 95 standard (ISO/IEC 1539-3:1998) defines --- 237,257 ---- preprocessor, FPP) to allow for conditional compilation. In the case of GNU Fortran, this is the GNU C Preprocessor in the traditional mode. On systems with case-preserving file names, the preprocessor is ! automatically invoked if the filename extension is `.F', `.FOR', ! `.FTN', `.fpp', `.FPP', `.F90', `.F95', `.F03' or `.F08'. To manually ! invoke the preprocessor on any file, use `-cpp', to disable ! preprocessing on files where the preprocessor is run automatically, use ! `-nocpp'. ! If a preprocessed file includes another file with the Fortran ! `INCLUDE' statement, the included file is not preprocessed. To ! preprocess included files, use the equivalent preprocessor statement ! `#include'. ! ! If GNU Fortran invokes the preprocessor, `__GFORTRAN__' is defined ! and `__GNUC__', `__GNUC_MINOR__' and `__GNUC_PATCHLEVEL__' can be used ! to determine the version of the compiler. See *note Overview: (cpp)Top. ! for details. While CPP is the de-facto standard for preprocessing Fortran code, Part 3 of the Fortran 95 standard (ISO/IEC 1539-3:1998) defines *************** on it for a while, of course). *** 287,296 **** standard-compliant Fortran 95, Fortran 90, and Fortran 77 programs, including a number of standard and non-standard extensions, and can be used on real-world programs. In particular, the supported extensions ! include OpenMP, Cray-style pointers, and several Fortran 2003 features ! such as enumeration, stream I/O, and some of the enhancements to ! allocatable array support from TR 15581. However, it is still under ! development and has a few remaining rough edges. At present, the GNU Fortran compiler passes the NIST Fortran 77 Test Suite (http://www.fortran-2000.com/ArnaudRecipes/fcvs21_f95.html), and --- 293,302 ---- standard-compliant Fortran 95, Fortran 90, and Fortran 77 programs, including a number of standard and non-standard extensions, and can be used on real-world programs. In particular, the supported extensions ! include OpenMP, Cray-style pointers, and several Fortran 2003 and ! Fortran 2008 features such as enumeration, stream I/O, and some of the ! enhancements to allocatable array support from TR 15581. However, it is ! still under development and has a few remaining rough edges. At present, the GNU Fortran compiler passes the NIST Fortran 77 Test Suite (http://www.fortran-2000.com/ArnaudRecipes/fcvs21_f95.html), and *************** enhancements to allocatable arrays, and *** 330,338 **** Interface v2.5 (http://www.openmp.org/drupal/mp-documents/spec25.pdf) specification. ! In the future, the GNU Fortran compiler may also support other ! standard variants of and extensions to the Fortran language. These ! include ISO/IEC 1539-1:2004 (Fortran 2003).  File: gfortran.info, Node: Invoking GNU Fortran, Next: Runtime, Prev: Introduction, Up: Top --- 336,354 ---- Interface v2.5 (http://www.openmp.org/drupal/mp-documents/spec25.pdf) specification. ! In the future, the GNU Fortran compiler will also support ISO/IEC ! 1539-1:2004 (Fortran 2003) and future Fortran standards. Partial support ! of that standard is already provided; the current status of Fortran 2003 ! support is reported in the *note Fortran 2003 status:: section of the ! documentation. ! ! The next version of the Fortran standard after Fortran 2003 is ! currently being developed and the GNU Fortran compiler supports some of ! its new features. This support is based on the latest draft of the ! standard (available from `http://www.nag.co.uk/sc22wg5/') and no ! guarantee of future compatibility is made, as the final standard might ! differ from the draft. For more information, see the *note Fortran 2008 ! status:: section.  File: gfortran.info, Node: Invoking GNU Fortran, Next: Runtime, Prev: Introduction, Up: Top *************** only one of these two forms, whichever o *** 362,367 **** --- 378,384 ---- without explanations. * Fortran Dialect Options:: Controlling the variant of Fortran language compiled. + * Preprocessing Options:: Enable and customize preprocessing. * Error and Warning Options:: How picky should the compiler be? * Debugging Options:: Symbol tables, measurements, and debugging dumps. * Directory Options:: Where to find module files *************** _Fortran Language Options_ *** 390,403 **** -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 -fcray-pointer -fopenmp -fno-range-check -fbackslash -fmodule-private _Error and Warning Options_ *Note Options to request or suppress errors and warnings: Error and Warning Options. -fmax-errors=N -fsyntax-only -pedantic -pedantic-errors ! -Wall -Waliasing -Wampersand -Wcharacter-truncation -Wconversion ! -Wimplicit-interface -Wline-truncation -Wnonstd-intrinsics -Wsurprising ! -Wno-tabs -Wunderflow -Wunused-parameter _Debugging Options_ *Note Options for debugging your program or GNU Fortran: Debugging --- 407,429 ---- -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 -fcray-pointer -fopenmp -fno-range-check -fbackslash -fmodule-private + _Preprocessing Options_ + *Note Enable and customize preprocessing: Preprocessing Options. + -cpp -dD -dI -dM -dN -dU -fworking-directory + -imultilib DIR -iprefix FILE -isysroot DIR + -iquote -isystem DIR -nocpp -nostdinc -undef + -AQUESTION=ANSWER -A-QUESTION[=ANSWER] + -C -CC -DMACRO[=DEFN] -UMACRO -H -P + _Error and Warning Options_ *Note Options to request or suppress errors and warnings: Error and Warning Options. -fmax-errors=N -fsyntax-only -pedantic -pedantic-errors ! -Wall -Waliasing -Wampersand -Warray-bounds -Wcharacter-truncation ! -Wconversion -Wimplicit-interface -Wline-truncation -Wintrinsics-std ! -Wsurprising -Wno-tabs -Wunderflow -Wunused-parameter -Wintrinsics-shadow ! -Wno-align-commons _Debugging Options_ *Note Options for debugging your program or GNU Fortran: Debugging *************** _Debugging Options_ *** 407,413 **** _Directory Options_ *Note Options for directory search: Directory Options. ! -IDIR -JDIR -MDIR -fintrinsic-modules-path DIR _Link Options_ *Note Options for influencing the linking step: Link Options. --- 433,440 ---- _Directory Options_ *Note Options for directory search: Directory Options. ! -IDIR -JDIR -MDIR ! -fintrinsic-modules-path DIR _Link Options_ *Note Options for influencing the linking step: Link Options. *************** _Link Options_ *** 415,438 **** _Runtime Options_ *Note Options for influencing runtime behavior: Runtime Options. ! -fconvert=CONVERSION -frecord-marker=LENGTH ! -fmax-subrecord-length=LENGTH -fsign-zero _Code Generation Options_ *Note Options for code generation conventions: Code Gen Options. -fno-automatic -ff2c -fno-underscoring -fsecond-underscore ! -fbounds-check -fmax-stack-var-size=N -fpack-derived -frepack-arrays -fshort-enums -fexternal-blas -fblas-matmul-limit=N -frecursive -finit-local-zero -finit-integer=N -finit-real= ! -finit-logical= -finit-character=N * Menu: * Fortran Dialect Options:: Controlling the variant of Fortran language compiled. * Error and Warning Options:: How picky should the compiler be? * Debugging Options:: Symbol tables, measurements, and debugging dumps. * Directory Options:: Where to find module files --- 442,468 ---- _Runtime Options_ *Note Options for influencing runtime behavior: Runtime Options. ! -fconvert=CONVERSION -fno-range-check ! -frecord-marker=LENGTH -fmax-subrecord-length=LENGTH ! -fsign-zero _Code Generation Options_ *Note Options for code generation conventions: Code Gen Options. -fno-automatic -ff2c -fno-underscoring -fsecond-underscore ! -fbounds-check -fcheck-array-temporaries -fmax-array-constructor =N ! -fmax-stack-var-size=N -fpack-derived -frepack-arrays -fshort-enums -fexternal-blas -fblas-matmul-limit=N -frecursive -finit-local-zero -finit-integer=N -finit-real= ! -finit-logical= -finit-character=N -fno-align-commons * Menu: * Fortran Dialect Options:: Controlling the variant of Fortran language compiled. + * Preprocessing Options:: Enable and customize preprocessing. * Error and Warning Options:: How picky should the compiler be? * Debugging Options:: Symbol tables, measurements, and debugging dumps. * Directory Options:: Where to find module files *************** _Code Generation Options_ *** 442,448 **** and register usage.  ! File: gfortran.info, Node: Fortran Dialect Options, Next: Error and Warning Options, Prev: Option Summary, Up: Invoking GNU Fortran 2.2 Options controlling Fortran dialect ======================================= --- 472,478 ---- and register usage.  ! File: gfortran.info, Node: Fortran Dialect Options, Next: Preprocessing Options, Prev: Option Summary, Up: Invoking GNU Fortran 2.2 Options controlling Fortran dialect ======================================= *************** accepted by the compiler: *** 459,468 **** source form is determined by the file extension. `-fall-intrinsics' ! Accept all of the intrinsic procedures provided in libgfortran ! without regard to the setting of `-std'. In particular, this ! option can be quite useful with `-std=f95'. Additionally, ! `gfortran' will ignore `-Wnonstd-intrinsics'. `-fd-lines-as-code' --- 489,501 ---- source form is determined by the file extension. `-fall-intrinsics' ! This option causes all intrinsic procedures (including the ! GNU-specific extensions) to be accepted. This can be useful with ! `-std=f95' to force standard-compliance but get access to the full ! range of intrinsics available with `gfortran'. As a consequence, ! `-Wintrinsics-std' will be ignored and no user-defined procedure ! with the same name as any intrinsic will be called except when it ! is explicitly declared `EXTERNAL'. `-fd-lines-as-code' *************** accepted by the compiler: *** 474,499 **** comment lines. `-fdefault-double-8' ! Set the `DOUBLE PRECISION' type to an 8 byte wide type. `-fdefault-integer-8' Set the default integer and logical types to an 8 byte wide type. ! Do nothing if this is already the default. `-fdefault-real-8' Set the default real type to an 8 byte wide type. Do nothing if ! this is already the default. `-fdollar-ok' Allow `$' as a valid character in a symbol name. `-fbackslash' Change the interpretation of backslashes in string literals from a ! single backslash character to "C-style" escape characters. The ! following combinations are expanded \a, \b, \f, \n, \r, \t, \v, ! \\, and \0 to the ASCII characters alert, backspace, form feed, ! newline, carriage return, horizontal tab, vertical tab, backslash, ! and NUL, respectively. All other combinations of a character preceded by \ are unexpanded. `-fmodule-private' --- 507,544 ---- comment lines. `-fdefault-double-8' ! Set the `DOUBLE PRECISION' type to an 8 byte wide type. If ! `-fdefault-real-8' is given, `DOUBLE PRECISION' would instead be ! promoted to 16 bytes if possible, and `-fdefault-double-8' can be ! used to prevent this. The kind of real constants like `1.d0' will ! not be changed by `-fdefault-real-8' though, so also ! `-fdefault-double-8' does not affect it. `-fdefault-integer-8' Set the default integer and logical types to an 8 byte wide type. ! Do nothing if this is already the default. This option also ! affects the kind of integer constants like `42'. `-fdefault-real-8' Set the default real type to an 8 byte wide type. Do nothing if ! this is already the default. This option also affects the kind of ! non-double real constants like `1.0', and does promote the default ! width of `DOUBLE PRECISION' to 16 bytes if possible, unless ! `-fdefault-double-8' is given, too. `-fdollar-ok' Allow `$' as a valid character in a symbol name. `-fbackslash' Change the interpretation of backslashes in string literals from a ! single backslash character to "C-style" escape characters. The ! following combinations are expanded `\a', `\b', `\f', `\n', `\r', ! `\t', `\v', `\\', and `\0' to the ASCII characters alert, ! backspace, form feed, newline, carriage return, horizontal tab, ! vertical tab, backslash, and NUL, respectively. Additionally, ! `\x'NN, `\u'NNNN and `\U'NNNNNNNN (where each N is a hexadecimal ! digit) are translated into the Unicode characters corresponding to ! the specified code points. All other combinations of a character preceded by \ are unexpanded. `-fmodule-private' *************** accepted by the compiler: *** 523,529 **** `-fmax-identifier-length=N' Specify the maximum allowed identifier length. Typical values are ! 31 (Fortran 95) and 63 (Fortran 2003). `-fimplicit-none' Specify that no implicit typing is allowed, unless overridden by --- 568,574 ---- `-fmax-identifier-length=N' Specify the maximum allowed identifier length. Typical values are ! 31 (Fortran 95) and 63 (Fortran 2003 and Fortran 2008). `-fimplicit-none' Specify that no implicit typing is allowed, unless overridden by *************** accepted by the compiler: *** 556,579 **** `-std=STD' Specify the standard to which the program is expected to conform, ! which may be one of `f95', `f2003', `gnu', or `legacy'. The ! default value for STD is `gnu', which specifies a superset of the ! Fortran 95 standard that includes all of the extensions supported ! by GNU Fortran, although warnings will be given for obsolete ! extensions not recommended for use in new code. The `legacy' value ! is equivalent but without the warnings for obsolete extensions, ! and may be useful for old non-standard programs. The `f95' and ! `f2003' values specify strict conformance to the Fortran 95 and ! Fortran 2003 standards, respectively; errors are given for all ! extensions beyond the relevant language standard, and warnings are ! given for the Fortran 77 features that are permitted but ! obsolescent in later standards.  ! File: gfortran.info, Node: Error and Warning Options, Next: Debugging Options, Prev: Fortran Dialect Options, Up: Invoking GNU Fortran ! 2.3 Options to request or suppress errors and warnings ====================================================== Errors are diagnostic messages that report that the GNU Fortran compiler --- 601,814 ---- `-std=STD' Specify the standard to which the program is expected to conform, ! which may be one of `f95', `f2003', `f2008', `gnu', or `legacy'. ! The default value for STD is `gnu', which specifies a superset of ! the Fortran 95 standard that includes all of the extensions ! supported by GNU Fortran, although warnings will be given for ! obsolete extensions not recommended for use in new code. The ! `legacy' value is equivalent but without the warnings for obsolete ! extensions, and may be useful for old non-standard programs. The ! `f95', `f2003' and `f2008' values specify strict conformance to ! the Fortran 95, Fortran 2003 and Fortran 2008 standards, ! respectively; errors are given for all extensions beyond the ! relevant language standard, and warnings are given for the Fortran ! 77 features that are permitted but obsolescent in later standards.  ! File: gfortran.info, Node: Preprocessing Options, Next: Error and Warning Options, Prev: Fortran Dialect Options, Up: Invoking GNU Fortran ! 2.3 Enable and customize preprocessing ! ====================================== ! ! Preprocessor related options. See section *note Preprocessing and ! conditional compilation:: for more detailed information on ! preprocessing in `gfortran'. ! ! `-cpp' ! ! `-nocpp' ! Enable preprocessing. The preprocessor is automatically invoked if ! the file extension is `.fpp', `.FPP', `.F', `.FOR', `.FTN', ! `.F90', `.F95', `.F03' or `.F08'. Use this option to manually ! enable preprocessing of any kind of Fortran file. ! ! To disable preprocessing of files with any of the above listed ! extensions, use the negative form: `-nocpp'. ! ! The preprocessor is run in traditional mode, be aware that any ! restrictions of the file-format, e.g. fixed-form line width, apply ! for preprocessed output as well. ! ! `-dM' ! Instead of the normal output, generate a list of `'#define'' ! directives for all the macros defined during the execution of the ! preprocessor, including predefined macros. This gives you a way of ! finding out what is predefined in your version of the preprocessor. ! Assuming you have no file `foo.f90', the command ! touch foo.f90; gfortran -cpp -dM foo.f90 ! will show all the predefined macros. ! ! `-dD' ! Like `-dM' except in two respects: it does not include the ! predefined macros, and it outputs both the `#define' directives ! and the result of preprocessing. Both kinds of output go to the ! standard output file. ! ! `-dN' ! Like `-dD', but emit only the macro names, not their expansions. ! ! `-dU' ! Like `dD' except that only macros that are expanded, or whose ! definedness is tested in preprocessor directives, are output; the ! output is delayed until the use or test of the macro; and ! `'#undef'' directives are also output for macros tested but ! undefined at the time. ! ! `-dI' ! Output `'#include'' directives in addition to the result of ! preprocessing. ! ! `-fworking-directory' ! Enable generation of linemarkers in the preprocessor output that ! will let the compiler know the current working directory at the ! time of preprocessing. When this option is enabled, the ! preprocessor will emit, after the initial linemarker, a second ! linemarker with the current working directory followed by two ! slashes. GCC will use this directory, when it's present in the ! preprocessed input, as the directory emitted as the current ! working directory in some debugging information formats. This ! option is implicitly enabled if debugging information is enabled, ! but this can be inhibited with the negated form ! `-fno-working-directory'. If the `-P' flag is present in the ! command line, this option has no effect, since no `#line' ! directives are emitted whatsoever. ! ! `-idirafter DIR' ! Search DIR for include files, but do it after all directories ! specified with `-I' and the standard system directories have been ! exhausted. DIR is treated as a system include directory. If dir ! begins with `=', then the `=' will be replaced by the sysroot ! prefix; see `--sysroot' and `-isysroot'. ! ! `-imultilib DIR' ! Use DIR as a subdirectory of the directory containing ! target-specific C++ headers. ! ! `-iprefix PREFIX' ! Specify PREFIX as the prefix for subsequent `-iwithprefix' ! options. If the PREFIX represents a directory, you should include ! the final `'/''. ! ! `-isysroot DIR' ! This option is like the `--sysroot' option, but applies only to ! header files. See the `--sysroot' option for more information. ! ! `-iquote DIR' ! Search DIR only for header files requested with `#include "file"'; ! they are not searched for `#include ', before all directories ! specified by `-I' and before the standard system directories. If ! DIR begins with `=', then the `=' will be replaced by the sysroot ! prefix; see `--sysroot' and `-isysroot'. ! ! `-isystem DIR' ! Search DIR for header files, after all directories specified by ! `-I' but before the standard system directories. Mark it as a ! system directory, so that it gets the same special treatment as is ! applied to the standard system directories. If DIR begins with ! `=', then the `=' will be replaced by the sysroot prefix; see ! `--sysroot' and `-isysroot'. ! ! `-nostdinc' ! Do not search the standard system directories for header files. ! Only the directories you have specified with `-I' options (and the ! directory of the current file, if appropriate) are searched. ! ! `-undef' ! Do not predefine any system-specific or GCC-specific macros. The ! standard predefined macros remain defined. ! ! `-APREDICATE=ANSWER' ! Make an assertion with the predicate PREDICATE and answer ANSWER. ! This form is preferred to the older form -A predicate(answer), ! which is still supported, because it does not use shell special ! characters. ! ! `-A-PREDICATE=ANSWER' ! Cancel an assertion with the predicate PREDICATE and answer ANSWER. ! ! `-C' ! Do not discard comments. All comments are passed through to the ! output file, except for comments in processed directives, which ! are deleted along with the directive. ! ! You should be prepared for side effects when using `-C'; it causes ! the preprocessor to treat comments as tokens in their own right. ! For example, comments appearing at the start of what would be a ! directive line have the effect of turning that line into an ! ordinary source line, since the first token on the line is no ! longer a `'#''. ! ! Warning: this currently handles C-Style comments only. The ! preprocessor does not yet recognize Fortran-style comments. ! ! `-CC' ! Do not discard comments, including during macro expansion. This is ! like `-C', except that comments contained within macros are also ! passed through to the output file where the macro is expanded. ! ! In addition to the side-effects of the `-C' option, the `-CC' ! option causes all C++-style comments inside a macro to be ! converted to C-style comments. This is to prevent later use of ! that macro from inadvertently commenting out the remainder of the ! source line. The `-CC' option is generally used to support lint ! comments. ! ! Warning: this currently handles C- and C++-Style comments only. The ! preprocessor does not yet recognize Fortran-style comments. ! ! `-DNAME' ! Predefine name as a macro, with definition `1'. ! ! `-DNAME=DEFINITION' ! The contents of DEFINITION are tokenized and processed as if they ! appeared during translation phase three in a `'#define'' directive. ! In particular, the definition will be truncated by embedded newline ! characters. ! ! If you are invoking the preprocessor from a shell or shell-like ! program you may need to use the shell's quoting syntax to protect ! characters such as spaces that have a meaning in the shell syntax. ! ! If you wish to define a function-like macro on the command line, ! write its argument list with surrounding parentheses before the ! equals sign (if any). Parentheses are meaningful to most shells, ! so you will need to quote the option. With sh and csh, ! `-D'name(args...)=definition'' works. ! ! `-D' and `-U' options are processed in the order they are given on ! the command line. All -imacros file and -include file options are ! processed after all -D and -U options. ! ! `-H' ! Print the name of each header file used, in addition to other ! normal activities. Each name is indented to show how deep in the ! `'#include'' stack it is. ! ! `-P' ! Inhibit generation of linemarkers in the output from the ! preprocessor. This might be useful when running the preprocessor ! on something that is not C code, and will be sent to a program ! which might be confused by the linemarkers. ! ! `-UNAME' ! Cancel any previous definition of NAME, either built in or provided ! with a `-D' option. ! !  ! File: gfortran.info, Node: Error and Warning Options, Next: Debugging Options, Prev: Preprocessing Options, Up: Invoking GNU Fortran ! ! 2.4 Options to request or suppress errors and warnings ====================================================== Errors are diagnostic messages that report that the GNU Fortran compiler *************** produced by GNU Fortran: *** 623,629 **** want--it finds some nonstandard practices, but not all. However, improvements to GNU Fortran in this area are welcome. ! This should be used in conjunction with `-std=f95' or `-std=f2003'. `-pedantic-errors' Like `-pedantic', except that errors are produced rather than --- 858,865 ---- want--it finds some nonstandard practices, but not all. However, improvements to GNU Fortran in this area are welcome. ! This should be used in conjunction with `-std=f95', `-std=f2003' ! or `-std=f2008'. `-pedantic-errors' Like `-pedantic', except that errors are produced rather than *************** produced by GNU Fortran: *** 633,639 **** Enables commonly used warning options pertaining to usage that we recommend avoiding and that we believe are easy to avoid. This currently includes `-Waliasing', `-Wampersand', `-Wsurprising', ! `-Wnonstd-intrinsics', `-Wno-tabs', and `-Wline-truncation'. `-Waliasing' Warn about possible aliasing of dummy arguments. Specifically, it --- 869,876 ---- Enables commonly used warning options pertaining to usage that we recommend avoiding and that we believe are easy to avoid. This currently includes `-Waliasing', `-Wampersand', `-Wsurprising', ! `-Wintrinsics-std', `-Wno-tabs', `-Wintrinsic-shadow' and ! `-Wline-truncation'. `-Waliasing' Warn about possible aliasing of dummy arguments. Specifically, it *************** produced by GNU Fortran: *** 654,668 **** `-Wampersand' Warn about missing ampersand in continued character constants. The ! warning is given with `-Wampersand', `-pedantic', `-std=f95', and ! `-std=f2003'. Note: With no ampersand given in a continued ! character constant, GNU Fortran assumes continuation at the first ! non-comment, non-whitespace character after the ampersand that ! initiated the continuation. `-Wcharacter-truncation' Warn when a character assignment will truncate the assigned string. `-Wconversion' Warn about implicit conversions between different types. --- 891,913 ---- `-Wampersand' Warn about missing ampersand in continued character constants. The ! warning is given with `-Wampersand', `-pedantic', `-std=f95', ! `-std=f2003' and `-std=f2008'. Note: With no ampersand given in a ! continued character constant, GNU Fortran assumes continuation at ! the first non-comment, non-whitespace character after the ampersand ! that initiated the continuation. ! ! `-Warray-temporaries' ! Warn about array temporaries generated by the compiler. The ! information generated by this warning is sometimes useful in ! optimization, in order to avoid such temporaries. `-Wcharacter-truncation' Warn when a character assignment will truncate the assigned string. + `-Wline-truncation' + Warn when a source code line will be truncated. + `-Wconversion' Warn about implicit conversions between different types. *************** produced by GNU Fortran: *** 672,680 **** not check that the declared interfaces are consistent across program units. ! `-Wnonstd-intrinsics' ! Warn if the user tries to use an intrinsic that does not belong to ! the standard the user has chosen via the `-std' option. `-Wsurprising' Produce a warning when "suspicious" code constructs are --- 917,928 ---- not check that the declared interfaces are consistent across program units. ! `-Wintrinsics-std' ! Warn if `gfortran' finds a procedure named like an intrinsic not ! available in the currently selected standard (with `-std') and ! treats it as `EXTERNAL' procedure because of this. ! `-fall-intrinsics' can be used to never trigger this behaviour and ! always link to the intrinsic regardless of the selected standard. `-Wsurprising' Produce a warning when "suspicious" code constructs are *************** produced by GNU Fortran: *** 692,709 **** * A TRANSFER specifies a source that is shorter than the destination. `-Wtabs' By default, tabs are accepted as whitespace, but tabs are not members of the Fortran Character Set. For continuation lines, a tab followed by a digit between 1 and 9 is supported. `-Wno-tabs' will cause a warning to be issued if a tab is encountered. Note, `-Wno-tabs' is active for `-pedantic', `-std=f95', `-std=f2003', ! and `-Wall'. `-Wunderflow' Produce a warning when numerical constant expressions are encountered, which yield an UNDERFLOW during compilation. `-Wunused-parameter' Contrary to `gcc''s meaning of `-Wunused-parameter', `gfortran''s implementation of this option does not warn about unused dummy --- 940,967 ---- * A TRANSFER specifies a source that is shorter than the destination. + * The type of a function result is declared more than once with + the same type. If `-pedantic' or standard-conforming mode is + enabled, this is an error. + `-Wtabs' By default, tabs are accepted as whitespace, but tabs are not members of the Fortran Character Set. For continuation lines, a tab followed by a digit between 1 and 9 is supported. `-Wno-tabs' will cause a warning to be issued if a tab is encountered. Note, `-Wno-tabs' is active for `-pedantic', `-std=f95', `-std=f2003', ! `-std=f2008' and `-Wall'. `-Wunderflow' Produce a warning when numerical constant expressions are encountered, which yield an UNDERFLOW during compilation. + `-Wintrinsic-shadow' + Warn if a user-defined procedure or module procedure has the same + name as an intrinsic; in this case, an explicit interface or + `EXTERNAL' or `INTRINSIC' declaration might be needed to get calls + later resolved to the desired intrinsic/procedure. + `-Wunused-parameter' Contrary to `gcc''s meaning of `-Wunused-parameter', `gfortran''s implementation of this option does not warn about unused dummy *************** produced by GNU Fortran: *** 711,716 **** --- 969,980 ---- `-Wunused-parameter' is not included in `-Wall' but is implied by `-Wall -Wextra'. + `-Walign-commons' + By default, `gfortran' warns about any occasion of variables being + padded for proper alignment inside a COMMON block. This warning + can be turned off via `-Wno-align-commons'. See also + `-falign-commons'. + `-Werror' Turns all warnings into errors. *************** Fortran. *** 724,730 ****  File: gfortran.info, Node: Debugging Options, Next: Directory Options, Prev: Error and Warning Options, Up: Invoking GNU Fortran ! 2.4 Options for debugging your program or GNU Fortran ===================================================== GNU Fortran has various special options that are used for debugging --- 988,994 ----  File: gfortran.info, Node: Debugging Options, Next: Directory Options, Prev: Error and Warning Options, Up: Invoking GNU Fortran ! 2.5 Options for debugging your program or GNU Fortran ===================================================== GNU Fortran has various special options that are used for debugging *************** either your program or the GNU Fortran c *** 747,753 **** and `denormal' (operation produced a denormal value). Some of the routines in the Fortran runtime library, like ! `CPU_TIME', are likely to to trigger floating point exceptions when `ffpe-trap=precision' is used. For this reason, the use of `ffpe-trap=precision' is not recommended. --- 1011,1017 ---- and `denormal' (operation produced a denormal value). Some of the routines in the Fortran runtime library, like ! `CPU_TIME', are likely to trigger floating point exceptions when `ffpe-trap=precision' is used. For this reason, the use of `ffpe-trap=precision' is not recommended. *************** Options, for more information on debuggi *** 770,776 ****  File: gfortran.info, Node: Directory Options, Next: Link Options, Prev: Debugging Options, Up: Invoking GNU Fortran ! 2.5 Options for directory search ================================ These options affect how GNU Fortran searches for files specified by --- 1034,1040 ----  File: gfortran.info, Node: Directory Options, Next: Link Options, Prev: Debugging Options, Up: Invoking GNU Fortran ! 2.6 Options for directory search ================================ These options affect how GNU Fortran searches for files specified by *************** preprocess Fortran source. *** 795,811 **** *Note Options for Directory Search: (gcc)Directory Options, for information on the `-I' option. - `-MDIR' - `-JDIR' This option specifies where to put `.mod' files for compiled modules. It is also added to the list of directories to searched by an `USE' statement. The default is the current directory. ! `-J' is an alias for `-M' to avoid conflicts with existing GCC ! options. `-fintrinsic-modules-path DIR' This option specifies the location of pre-compiled intrinsic --- 1059,1074 ---- *Note Options for Directory Search: (gcc)Directory Options, for information on the `-I' option. `-JDIR' + + `-MDIR' This option specifies where to put `.mod' files for compiled modules. It is also added to the list of directories to searched by an `USE' statement. The default is the current directory. ! `-M' is deprecated to avoid conflicts with existing GCC options. `-fintrinsic-modules-path DIR' This option specifies the location of pre-compiled intrinsic *************** preprocess Fortran source. *** 815,821 ****  File: gfortran.info, Node: Link Options, Next: Runtime Options, Prev: Directory Options, Up: Invoking GNU Fortran ! 2.6 Influencing the linking step ================================ These options come into play when the compiler links object files into --- 1078,1084 ----  File: gfortran.info, Node: Link Options, Next: Runtime Options, Prev: Directory Options, Up: Invoking GNU Fortran ! 2.7 Influencing the linking step ================================ These options come into play when the compiler links object files into *************** doing a link step. *** 831,837 ****  File: gfortran.info, Node: Runtime Options, Next: Code Gen Options, Prev: Link Options, Up: Invoking GNU Fortran ! 2.7 Influencing runtime behavior ================================ These options affect the runtime behavior of programs compiled with GNU --- 1094,1100 ----  File: gfortran.info, Node: Runtime Options, Next: Code Gen Options, Prev: Link Options, Up: Invoking GNU Fortran ! 2.8 Influencing runtime behavior ================================ These options affect the runtime behavior of programs compiled with GNU *************** Fortran. *** 847,852 **** --- 1110,1123 ---- The `CONVERT' specifier and the GFORTRAN_CONVERT_UNIT environment variable override the default specified by `-fconvert'._ + `-fno-range-check' + Disable range checking of input values during integer `READ' + operations. For example, GNU Fortran will give an error if an + input value is outside of the relevant range of + [`-HUGE()':`HUGE()']. In other words, with `INTEGER (kind=4) :: i' + , attempting to read -2147483648 will give an error unless + `-fno-range-check' is given. + `-frecord-marker=LENGTH' Specify the length of record markers for unformatted files. Valid values for LENGTH are 4 and 8. Default is 4. _This is different *************** Fortran. *** 869,875 ****  File: gfortran.info, Node: Code Gen Options, Next: Environment Variables, Prev: Runtime Options, Up: Invoking GNU Fortran ! 2.8 Options for code generation conventions =========================================== These machine-independent options control the interface conventions --- 1140,1146 ----  File: gfortran.info, Node: Code Gen Options, Next: Environment Variables, Prev: Runtime Options, Up: Invoking GNU Fortran ! 2.9 Options for code generation conventions =========================================== These machine-independent options control the interface conventions *************** the other form by either removing `no-' *** 999,1011 **** Enable generation of run-time checks for array subscripts and against the declared minimum and maximum values. It also checks array indices for assumed and deferred shape arrays against the ! actual allocated bounds. Some checks require that `-fbounds-check' is set for the compilation of the main program. ! In the future this may also include other forms of checking, e.g., ! checking substring references. `-fmax-stack-var-size=N' This option specifies the size in bytes of the largest array that --- 1270,1310 ---- Enable generation of run-time checks for array subscripts and against the declared minimum and maximum values. It also checks array indices for assumed and deferred shape arrays against the ! actual allocated bounds and ensures that all string lengths are ! equal for character array constructors without an explicit ! typespec. Some checks require that `-fbounds-check' is set for the compilation of the main program. ! Note: In the future this may also include other forms of checking, ! e.g., checking substring references. ! ! `fcheck-array-temporaries' ! Warns at run time when for passing an actual argument a temporary ! array had to be generated. The information generated by this ! warning is sometimes useful in optimization, in order to avoid ! such temporaries. ! ! Note: The warning is only printed once per location. ! ! `-fmax-array-constructor=N' ! This option can be used to increase the upper limit permitted in ! array constructors. The code below requires this option to expand ! the array at compile time. ! ! `program test' ! `implicit none' ! `integer j' ! `integer, parameter :: n = 100000' ! `integer, parameter :: i(n) = (/ (2*j, j = 1, n) /)' ! `print '(10(I0,1X))', i' ! `end program test' ! ! _Caution: This option can lead to long compile times and ! excessively large object files._ ! ! The default value for N is 65535. `-fmax-stack-var-size=N' This option specifies the size in bytes of the largest array that *************** the other form by either removing `no-' *** 1092,1097 **** --- 1391,1407 ---- Note that the `-finit-real=nan' option initializes `REAL' and `COMPLEX' variables with a quiet NaN. + `-falign-commons' + By default, `gfortran' enforces proper alignment of all variables + in a COMMON block by padding them as needed. On certain platforms + this is mandatory, on others it increases performance. If a COMMON + block is not declared with consistent data types everywhere, this + padding can cause trouble, and `-fno-align-commons ' can be used + to disable automatic alignment. The same form of this option + should be used for all files that share a COMMON block. To avoid + potential alignment issues in COMMON blocks, it is recommended to + order objects from largests to smallest. + *Note Options for Code Generation Conventions: (gcc)Code Gen Options, for information on more options offered by the GBE shared by `gfortran', `gcc', and other GNU compilers. *************** Options, for information on more options *** 1099,1106 ****  File: gfortran.info, Node: Environment Variables, Prev: Code Gen Options, Up: Invoking GNU Fortran ! 2.9 Environment variables affecting `gfortran' ! ============================================== The `gfortran' compiler currently does not make use of any environment variables to control its operation above and beyond those that affect --- 1409,1416 ----  File: gfortran.info, Node: Environment Variables, Prev: Code Gen Options, Up: Invoking GNU Fortran ! 2.10 Environment variables affecting `gfortran' ! =============================================== The `gfortran' compiler currently does not make use of any environment variables to control its operation above and beyond those that affect *************** Variables, for information on environmen *** 1113,1119 **** behavior of programs compiled with GNU Fortran.  ! File: gfortran.info, Node: Runtime, Next: Fortran 2003 status, Prev: Invoking GNU Fortran, Up: Top 3 Runtime: Influencing runtime behavior with environment variables ******************************************************************* --- 1423,1429 ---- behavior of programs compiled with GNU Fortran.  ! File: gfortran.info, Node: Runtime, Next: Fortran 2003 and 2008 status, Prev: Invoking GNU Fortran, Up: Top 3 Runtime: Influencing runtime behavior with environment variables ******************************************************************* *************** File: gfortran.info, Node: GFORTRAN_UNB *** 1209,1215 **** ============================================================================== The environment variable named `GFORTRAN_UNBUFFERED_PRECONNECTED' ! controls whether I/O on a preconnected unit (i.e STDOUT or STDERR) is unbuffered. If the first letter is `y', `Y' or `1', I/O is unbuffered. This will slow down small sequential reads and writes. If the first letter is `n', `N' or `0', I/O is buffered. This is the default. --- 1519,1525 ---- ============================================================================== The environment variable named `GFORTRAN_UNBUFFERED_PRECONNECTED' ! controls whether I/O on a preconnected unit (i.e. STDOUT or STDERR) is unbuffered. If the first letter is `y', `Y' or `1', I/O is unbuffered. This will slow down small sequential reads and writes. If the first letter is `n', `N' or `0', I/O is buffered. This is the default. *************** the same as for the `CONVERT' specifier: *** 1285,1292 **** `SWAP' Swap between little- and big-endian. ! `LITTLE_ENDIAN' Use the little-endian format for ! unformatted files. `BIG_ENDIAN' Use the big-endian format for unformatted files. A missing mode for an exception is taken to mean `BIG_ENDIAN'. --- 1595,1601 ---- `SWAP' Swap between little- and big-endian. ! `LITTLE_ENDIAN' Use the little-endian format for unformatted files. `BIG_ENDIAN' Use the big-endian format for unformatted files. A missing mode for an exception is taken to mean `BIG_ENDIAN'. *************** run-time error occurs. To disable the b *** 1351,1360 **** `-fbacktrace' compile option was used.  ! File: gfortran.info, Node: Fortran 2003 status, Next: Extensions, Prev: Runtime, Up: Top ! 4 Fortran 2003 Status ! ********************* Although GNU Fortran focuses on implementing the Fortran 95 standard for the time being, a few Fortran 2003 features are currently available. --- 1660,1680 ---- `-fbacktrace' compile option was used.  ! File: gfortran.info, Node: Fortran 2003 and 2008 status, Next: Compiler Characteristics, Prev: Runtime, Up: Top ! 4 Fortran 2003 and 2008 Status ! ****************************** ! ! * Menu: ! ! * Fortran 2003 status:: ! * Fortran 2008 status:: ! !  ! File: gfortran.info, Node: Fortran 2003 status, Next: Fortran 2008 status, Up: Fortran 2003 and 2008 status ! ! 4.1 Fortran 2003 status ! ======================= Although GNU Fortran focuses on implementing the Fortran 95 standard for the time being, a few Fortran 2003 features are currently available. *************** for the time being, a few Fortran 2003 f *** 1408,1416 ****  ! File: gfortran.info, Node: Extensions, Next: Intrinsic Procedures, Prev: Fortran 2003 status, Up: Top ! 5 Extensions ************ The two sections below detail the extensions to standard Fortran that --- 1728,1804 ----  ! File: gfortran.info, Node: Fortran 2008 status, Prev: Fortran 2003 status, Up: Fortran 2003 and 2008 status ! 4.2 Fortran 2008 status ! ======================= ! ! The next version of the Fortran standard after Fortran 2003 is currently ! being worked on by the Working Group 5 of Sub-Committee 22 of the Joint ! Technical Committee 1 of the International Organization for ! Standardization (ISO) and the International Electrotechnical Commission ! (IEC). This group is known at WG5 (http://www.nag.co.uk/sc22wg5/). The ! next revision of the Fortran standard is informally referred to as ! Fortran 2008, reflecting its planned release year. The GNU Fortran ! compiler has support for some of the new features in Fortran 2008. This ! support is based on the latest draft, available from ! `http://www.nag.co.uk/sc22wg5/'. However, as the final standard may ! differ from the drafts, no guarantee of backward compatibility can be ! made and you should only use it for experimental purposes. ! !  ! File: gfortran.info, Node: Compiler Characteristics, Next: Extensions, Prev: Fortran 2003 and 2008 status, Up: Top ! ! 5 Compiler Characteristics ! ************************** ! ! This chapter describes certain characteristics of the GNU Fortran ! compiler, namely the KIND type parameter values supported. ! ! * Menu: ! ! * KIND Type Parameters:: ! !  ! File: gfortran.info, Node: KIND Type Parameters, Up: Compiler Characteristics ! ! 5.1 KIND Type Parameters ! ======================== ! ! The `KIND' type parameters supported by GNU Fortran for the primitive ! data types are: ! ! `INTEGER' ! 1, 2, 4, 8*, 16*, default: 4 (1) ! ! `LOGICAL' ! 1, 2, 4, 8*, 16*, default: 4 (1) ! ! `REAL' ! 4, 8, 10**, 16**, default: 4 (2) ! ! `COMPLEX' ! 4, 8, 10**, 16**, default: 4 (2) ! ! `CHARACTER' ! 1, 4, default: 1 ! ! ! * = not available on all systems ! ** = not available on all systems; additionally 10 and 16 are never ! available at the same time ! (1) Unless -fdefault-integer-8 is used ! (2) Unless -fdefault-real-8 is used ! ! The `KIND' value matches the storage size in bytes, except for ! `COMPLEX' where the storage size is twice as much (or both real and ! imaginary part are a real value of the given size). It is recommended ! to use the `SELECT_*_KIND' intrinsics instead of the concrete values. ! !  ! File: gfortran.info, Node: Extensions, Next: Intrinsic Procedures, Prev: Compiler Characteristics, Up: Top ! ! 6 Extensions ************ The two sections below detail the extensions to standard Fortran that *************** extensions. *** 1428,1434 ****  File: gfortran.info, Node: Extensions implemented in GNU Fortran, Next: Extensions not implemented in GNU Fortran, Up: Extensions ! 5.1 Extensions implemented in GNU Fortran ========================================= GNU Fortran implements a number of extensions over standard Fortran. --- 1816,1822 ----  File: gfortran.info, Node: Extensions implemented in GNU Fortran, Next: Extensions not implemented in GNU Fortran, Up: Extensions ! 6.1 Extensions implemented in GNU Fortran ========================================= GNU Fortran implements a number of extensions over standard Fortran. *************** provide functionality beyond that provid *** 1438,1445 **** that are supported by GNU Fortran purely for backward compatibility with legacy compilers. By default, `-std=gnu' allows the compiler to accept both types of extensions, but to warn about the use of the ! latter. Specifying either `-std=f95' or `-std=f2003' disables both ! types of extensions, and `-std=legacy' allows both without warning. * Menu: --- 1826,1834 ---- that are supported by GNU Fortran purely for backward compatibility with legacy compilers. By default, `-std=gnu' allows the compiler to accept both types of extensions, but to warn about the use of the ! latter. Specifying either `-std=f95', `-std=f2003' or `-std=f2008' ! disables both types of extensions, and `-std=legacy' allows both ! without warning. * Menu: *************** types of extensions, and `-std=legacy' a *** 1463,1469 ****  File: gfortran.info, Node: Old-style kind specifications, Next: Old-style variable initialization, Up: Extensions implemented in GNU Fortran ! 5.1.1 Old-style kind specifications ----------------------------------- GNU Fortran allows old-style kind specifications in declarations. These --- 1852,1858 ----  File: gfortran.info, Node: Old-style kind specifications, Next: Old-style variable initialization, Up: Extensions implemented in GNU Fortran ! 6.1.1 Old-style kind specifications ----------------------------------- GNU Fortran allows old-style kind specifications in declarations. These *************** total size of the real and imaginary par *** 1476,1488 **** declares `x', `y' and `z' to be of type `TYPESPEC' with the appropriate kind. This is equivalent to the standard-conforming declaration TYPESPEC(k) x,y,z ! where `k' is equal to `size' for most types, but is equal to ! `size/2' for the `COMPLEX' type.  File: gfortran.info, Node: Old-style variable initialization, Next: Extensions to namelist, Prev: Old-style kind specifications, Up: Extensions implemented in GNU Fortran ! 5.1.2 Old-style variable initialization --------------------------------------- GNU Fortran allows old-style initialization of variables of the form: --- 1865,1881 ---- declares `x', `y' and `z' to be of type `TYPESPEC' with the appropriate kind. This is equivalent to the standard-conforming declaration TYPESPEC(k) x,y,z ! where `k' is the kind parameter suitable for the intended precision. ! As kind parameters are implementation-dependent, use the `KIND', ! `SELECTED_INT_KIND' and `SELECTED_REAL_KIND' intrinsics to retrieve the ! correct value, for instance `REAL*8 x' can be replaced by: ! INTEGER, PARAMETER :: dbl = KIND(1.0d0) ! REAL(KIND=dbl) :: x  File: gfortran.info, Node: Old-style variable initialization, Next: Extensions to namelist, Prev: Old-style kind specifications, Up: Extensions implemented in GNU Fortran ! 6.1.2 Old-style variable initialization --------------------------------------- GNU Fortran allows old-style initialization of variables of the form: *************** or in `DATA' statements automatically ac *** 1513,1519 ****  File: gfortran.info, Node: Extensions to namelist, Next: X format descriptor without count field, Prev: Old-style variable initialization, Up: Extensions implemented in GNU Fortran ! 5.1.3 Extensions to namelist ---------------------------- GNU Fortran fully supports the Fortran 95 standard for namelist I/O --- 1906,1912 ----  File: gfortran.info, Node: Extensions to namelist, Next: X format descriptor without count field, Prev: Old-style variable initialization, Up: Extensions implemented in GNU Fortran ! 6.1.3 Extensions to namelist ---------------------------- GNU Fortran fully supports the Fortran 95 standard for namelist I/O *************** be given the values 1.00 and 2.00. *** 1574,1580 ****  File: gfortran.info, Node: X format descriptor without count field, Next: Commas in FORMAT specifications, Prev: Extensions to namelist, Up: Extensions implemented in GNU Fortran ! 5.1.4 `X' format descriptor without count field ----------------------------------------------- To support legacy codes, GNU Fortran permits the count field of the `X' --- 1967,1973 ----  File: gfortran.info, Node: X format descriptor without count field, Next: Commas in FORMAT specifications, Prev: Extensions to namelist, Up: Extensions implemented in GNU Fortran ! 6.1.4 `X' format descriptor without count field ----------------------------------------------- To support legacy codes, GNU Fortran permits the count field of the `X' *************** the count is implicitly assumed to be on *** 1587,1593 ****  File: gfortran.info, Node: Commas in FORMAT specifications, Next: Missing period in FORMAT specifications, Prev: X format descriptor without count field, Up: Extensions implemented in GNU Fortran ! 5.1.5 Commas in `FORMAT' specifications --------------------------------------- To support legacy codes, GNU Fortran allows the comma separator to be --- 1980,1986 ----  File: gfortran.info, Node: Commas in FORMAT specifications, Next: Missing period in FORMAT specifications, Prev: X format descriptor without count field, Up: Extensions implemented in GNU Fortran ! 6.1.5 Commas in `FORMAT' specifications --------------------------------------- To support legacy codes, GNU Fortran allows the comma separator to be *************** in `FORMAT' statements. *** 1600,1606 ****  File: gfortran.info, Node: Missing period in FORMAT specifications, Next: I/O item lists, Prev: Commas in FORMAT specifications, Up: Extensions implemented in GNU Fortran ! 5.1.6 Missing period in `FORMAT' specifications ----------------------------------------------- To support legacy codes, GNU Fortran allows missing periods in format --- 1993,1999 ----  File: gfortran.info, Node: Missing period in FORMAT specifications, Next: I/O item lists, Prev: Commas in FORMAT specifications, Up: Extensions implemented in GNU Fortran ! 6.1.6 Missing period in `FORMAT' specifications ----------------------------------------------- To support legacy codes, GNU Fortran allows missing periods in format *************** line. This is considered non-conforming *** 1614,1620 ****  File: gfortran.info, Node: I/O item lists, Next: BOZ literal constants, Prev: Missing period in FORMAT specifications, Up: Extensions implemented in GNU Fortran ! 5.1.7 I/O item lists -------------------- To support legacy codes, GNU Fortran allows the input item list of the --- 2007,2013 ----  File: gfortran.info, Node: I/O item lists, Next: BOZ literal constants, Prev: Missing period in FORMAT specifications, Up: Extensions implemented in GNU Fortran ! 6.1.7 I/O item lists -------------------- To support legacy codes, GNU Fortran allows the input item list of the *************** statements, to start with a comma. *** 1624,1630 ****  File: gfortran.info, Node: BOZ literal constants, Next: Real array indices, Prev: I/O item lists, Up: Extensions implemented in GNU Fortran ! 5.1.8 BOZ literal constants --------------------------- Besides decimal constants, Fortran also supports binary (`b'), octal --- 2017,2023 ----  File: gfortran.info, Node: BOZ literal constants, Next: Real array indices, Prev: I/O item lists, Up: Extensions implemented in GNU Fortran ! 6.1.8 BOZ literal constants --------------------------- Besides decimal constants, Fortran also supports binary (`b'), octal *************** manner. *** 1671,1677 ****  File: gfortran.info, Node: Real array indices, Next: Unary operators, Prev: BOZ literal constants, Up: Extensions implemented in GNU Fortran ! 5.1.9 Real array indices ------------------------ As an extension, GNU Fortran allows the use of `REAL' expressions or --- 2064,2070 ----  File: gfortran.info, Node: Real array indices, Next: Unary operators, Prev: BOZ literal constants, Up: Extensions implemented in GNU Fortran ! 6.1.9 Real array indices ------------------------ As an extension, GNU Fortran allows the use of `REAL' expressions or *************** variables as array indices. *** 1680,1686 ****  File: gfortran.info, Node: Unary operators, Next: Implicitly convert LOGICAL and INTEGER values, Prev: Real array indices, Up: Extensions implemented in GNU Fortran ! 5.1.10 Unary operators ---------------------- As an extension, GNU Fortran allows unary plus and unary minus operators --- 2073,2079 ----  File: gfortran.info, Node: Unary operators, Next: Implicitly convert LOGICAL and INTEGER values, Prev: Real array indices, Up: Extensions implemented in GNU Fortran ! 6.1.10 Unary operators ---------------------- As an extension, GNU Fortran allows unary plus and unary minus operators *************** the need for parenthesis. *** 1692,1698 ****  File: gfortran.info, Node: Implicitly convert LOGICAL and INTEGER values, Next: Hollerith constants support, Prev: Unary operators, Up: Extensions implemented in GNU Fortran ! 5.1.11 Implicitly convert `LOGICAL' and `INTEGER' values -------------------------------------------------------- As an extension for backwards compatibility with other compilers, GNU --- 2085,2091 ----  File: gfortran.info, Node: Implicitly convert LOGICAL and INTEGER values, Next: Hollerith constants support, Prev: Unary operators, Up: Extensions implemented in GNU Fortran ! 6.1.11 Implicitly convert `LOGICAL' and `INTEGER' values -------------------------------------------------------- As an extension for backwards compatibility with other compilers, GNU *************** interpreted as `.TRUE.'. *** 1715,1721 ****  File: gfortran.info, Node: Hollerith constants support, Next: Cray pointers, Prev: Implicitly convert LOGICAL and INTEGER values, Up: Extensions implemented in GNU Fortran ! 5.1.12 Hollerith constants support ---------------------------------- GNU Fortran supports Hollerith constants in assignments, function --- 2108,2114 ----  File: gfortran.info, Node: Hollerith constants support, Next: Cray pointers, Prev: Implicitly convert LOGICAL and INTEGER values, Up: Extensions implemented in GNU Fortran ! 6.1.12 Hollerith constants support ---------------------------------- GNU Fortran supports Hollerith constants in assignments, function *************** obtained by using the `TRANSFER' stateme *** 1751,1757 ****  File: gfortran.info, Node: Cray pointers, Next: CONVERT specifier, Prev: Hollerith constants support, Up: Extensions implemented in GNU Fortran ! 5.1.13 Cray pointers -------------------- Cray pointers are part of a non-standard extension that provides a --- 2144,2150 ----  File: gfortran.info, Node: Cray pointers, Next: CONVERT specifier, Prev: Hollerith constants support, Up: Extensions implemented in GNU Fortran ! 6.1.13 Cray pointers -------------------- Cray pointers are part of a non-standard extension that provides a *************** will not change the base address of the *** 1865,1871 ****  File: gfortran.info, Node: CONVERT specifier, Next: OpenMP, Prev: Cray pointers, Up: Extensions implemented in GNU Fortran ! 5.1.14 `CONVERT' specifier -------------------------- GNU Fortran allows the conversion of unformatted data between little- --- 2258,2264 ----  File: gfortran.info, Node: CONVERT specifier, Next: OpenMP, Prev: Cray pointers, Up: Extensions implemented in GNU Fortran ! 6.1.14 `CONVERT' specifier -------------------------- GNU Fortran allows the conversion of unformatted data between little- *************** variable. *** 1880,1890 **** `CONVERT='SWAP'' Swap between little- and big-endian. ! `CONVERT='LITTLE_ENDIAN'' Use the little-endian representation ! for unformatted files. `CONVERT='BIG_ENDIAN'' Use the big-endian representation for ! unformatted files. Using the option could look like this: open(file='big.dat',form='unformatted',access='sequential', & --- 2273,2283 ---- `CONVERT='SWAP'' Swap between little- and big-endian. ! `CONVERT='LITTLE_ENDIAN'' Use the little-endian representation for ! unformatted files. `CONVERT='BIG_ENDIAN'' Use the big-endian representation for ! unformatted files. Using the option could look like this: open(file='big.dat',form='unformatted',access='sequential', & *************** you, it is best if you use this only for *** 1912,1918 ****  File: gfortran.info, Node: OpenMP, Next: Argument list functions, Prev: CONVERT specifier, Up: Extensions implemented in GNU Fortran ! 5.1.15 OpenMP ------------- OpenMP (Open Multi-Processing) is an application programming interface --- 2305,2311 ----  File: gfortran.info, Node: OpenMP, Next: Argument list functions, Prev: CONVERT specifier, Up: Extensions implemented in GNU Fortran ! 6.1.15 OpenMP ------------- OpenMP (Open Multi-Processing) is an application programming interface *************** OpenMP Application Program Interface v2. *** 1950,1956 **** END SUBROUTINE A1 Please note: ! * `-fopenmp' implies `-frecursive', i.e. all local arrays will be allocated on the stack. When porting existing code to OpenMP, this may lead to surprising results, especially to segmentation faults if the stacksize is limited. --- 2343,2349 ---- END SUBROUTINE A1 Please note: ! * `-fopenmp' implies `-frecursive', i.e., all local arrays will be allocated on the stack. When porting existing code to OpenMP, this may lead to surprising results, especially to segmentation faults if the stacksize is limited. *************** OpenMP Application Program Interface v2. *** 1965,1971 ****  File: gfortran.info, Node: Argument list functions, Prev: OpenMP, Up: Extensions implemented in GNU Fortran ! 5.1.16 Argument list functions `%VAL', `%REF' and `%LOC' -------------------------------------------------------- GNU Fortran supports argument list functions `%VAL', `%REF' and `%LOC' --- 2358,2364 ----  File: gfortran.info, Node: Argument list functions, Prev: OpenMP, Up: Extensions implemented in GNU Fortran ! 6.1.16 Argument list functions `%VAL', `%REF' and `%LOC' -------------------------------------------------------- GNU Fortran supports argument list functions `%VAL', `%REF' and `%LOC' *************** are worth a look. *** 2003,2017 ****  File: gfortran.info, Node: Extensions not implemented in GNU Fortran, Prev: Extensions implemented in GNU Fortran, Up: Extensions ! 5.2 Extensions not implemented in GNU Fortran ============================================= The long history of the Fortran language, its wide use and broad userbase, the large number of different compiler vendors and the lack of some features crucial to users in the first standards have lead to the ! existence of an important number of extensions to the language. While some of the most useful or popular extensions are supported by the GNU ! Fortran compiler, not all existing extensions are supported. This section aims at listing these extensions and offering advice on how best make code that uses them running with the GNU Fortran compiler. --- 2396,2410 ----  File: gfortran.info, Node: Extensions not implemented in GNU Fortran, Prev: Extensions implemented in GNU Fortran, Up: Extensions ! 6.2 Extensions not implemented in GNU Fortran ============================================= The long history of the Fortran language, its wide use and broad userbase, the large number of different compiler vendors and the lack of some features crucial to users in the first standards have lead to the ! existence of a number of important extensions to the language. While some of the most useful or popular extensions are supported by the GNU ! Fortran compiler, not all existing extensions are supported. This section aims at listing these extensions and offering advice on how best make code that uses them running with the GNU Fortran compiler. *************** best make code that uses them running wi *** 2023,2029 ****  File: gfortran.info, Node: STRUCTURE and RECORD, Next: ENCODE and DECODE statements, Up: Extensions not implemented in GNU Fortran ! 5.2.1 `STRUCTURE' and `RECORD' ------------------------------ Structures are user-defined aggregate data types; this functionality was --- 2416,2422 ----  File: gfortran.info, Node: STRUCTURE and RECORD, Next: ENCODE and DECODE statements, Up: Extensions not implemented in GNU Fortran ! 6.2.1 `STRUCTURE' and `RECORD' ------------------------------ Structures are user-defined aggregate data types; this functionality was *************** structure syntax: *** 2051,2057 **** store_catalog(7).description = "milk bottle" store_catalog(7).price = 1.2 ! ! We can also manipulates the whole structure store_catalog(12) = pear print *, store_catalog(12) --- 2444,2450 ---- store_catalog(7).description = "milk bottle" store_catalog(7).price = 1.2 ! ! We can also manipulate the whole structure store_catalog(12) = pear print *, store_catalog(12) *************** This code can easily be rewritten in the *** 2084,2090 ****  File: gfortran.info, Node: ENCODE and DECODE statements, Prev: STRUCTURE and RECORD, Up: Extensions not implemented in GNU Fortran ! 5.2.2 `ENCODE' and `DECODE' statements -------------------------------------- GNU Fortran doesn't support the `ENCODE' and `DECODE' statements. --- 2477,2483 ----  File: gfortran.info, Node: ENCODE and DECODE statements, Prev: STRUCTURE and RECORD, Up: Extensions not implemented in GNU Fortran ! 6.2.2 `ENCODE' and `DECODE' statements -------------------------------------- GNU Fortran doesn't support the `ENCODE' and `DECODE' statements. *************** with the following: *** 2126,2132 ****  File: gfortran.info, Node: Intrinsic Procedures, Next: Intrinsic Modules, Prev: Extensions, Up: Top ! 6 Intrinsic Procedures ********************** * Menu: --- 2519,2525 ----  File: gfortran.info, Node: Intrinsic Procedures, Next: Intrinsic Modules, Prev: Extensions, Up: Top ! 7 Intrinsic Procedures ********************** * Menu: *************** File: gfortran.info, Node: Intrinsic Pr *** 2154,2165 **** * `ATAN': ATAN, Arctangent function * `ATAN2': ATAN2, Arctangent function * `ATANH': ATANH, Hyperbolic arctangent function ! * `BESJ0': BESJ0, Bessel function of the first kind of order 0 ! * `BESJ1': BESJ1, Bessel function of the first kind of order 1 ! * `BESJN': BESJN, Bessel function of the first kind ! * `BESY0': BESY0, Bessel function of the second kind of order 0 ! * `BESY1': BESY1, Bessel function of the second kind of order 1 ! * `BESYN': BESYN, Bessel function of the second kind * `BIT_SIZE': BIT_SIZE, Bit size inquiry function * `BTEST': BTEST, Bit test function * `C_ASSOCIATED': C_ASSOCIATED, Status of a C pointer --- 2547,2558 ---- * `ATAN': ATAN, Arctangent function * `ATAN2': ATAN2, Arctangent function * `ATANH': ATANH, Hyperbolic arctangent function ! * `BESSEL_J0': BESSEL_J0, Bessel function of the first kind of order 0 ! * `BESSEL_J1': BESSEL_J1, Bessel function of the first kind of order 1 ! * `BESSEL_JN': BESSEL_JN, Bessel function of the first kind ! * `BESSEL_Y0': BESSEL_Y0, Bessel function of the second kind of order 0 ! * `BESSEL_Y1': BESSEL_Y1, Bessel function of the second kind of order 1 ! * `BESSEL_YN': BESSEL_YN, Bessel function of the second kind * `BIT_SIZE': BIT_SIZE, Bit size inquiry function * `BTEST': BTEST, Bit test function * `C_ASSOCIATED': C_ASSOCIATED, Status of a C pointer *************** File: gfortran.info, Node: Intrinsic Pr *** 2167,2172 **** --- 2560,2566 ---- * `C_F_PROCPOINTER': C_F_PROCPOINTER, Convert C into Fortran procedure pointer * `C_FUNLOC': C_FUNLOC, Obtain the C address of a procedure * `C_LOC': C_LOC, Obtain the C address of an object + * `C_SIZEOF': C_SIZEOF, Size in bytes of an expression * `CEILING': CEILING, Integer ceiling function * `CHAR': CHAR, Integer-to-character conversion function * `CHDIR': CHDIR, Change working directory *************** File: gfortran.info, Node: Intrinsic Pr *** 2195,2200 **** --- 2589,2595 ---- * `EPSILON': EPSILON, Epsilon function * `ERF': ERF, Error function * `ERFC': ERFC, Complementary error function + * `ERFC_SCALED': ERFC_SCALED, Exponentially-scaled complementary error function * `ETIME': ETIME, Execution time subroutine (or function) * `EXIT': EXIT, Exit the program with status. * `EXP': EXP, Exponential function *************** File: gfortran.info, Node: Intrinsic Pr *** 2228,2233 **** --- 2623,2629 ---- * `GMTIME': GMTIME, Convert time to GMT info * `HOSTNM': HOSTNM, Get system host name * `HUGE': HUGE, Largest number of a kind + * `HYPOT': HYPOT, Euclidian distance function * `IACHAR': IACHAR, Code in ASCII collating sequence * `IAND': IAND, Bitwise logical and * `IARGC': IARGC, Get the number of command line arguments *************** File: gfortran.info, Node: Intrinsic Pr *** 2254,2262 **** * `KILL': KILL, Send a signal to a process * `KIND': KIND, Kind of an entity * `LBOUND': LBOUND, Lower dimension bounds of an array * `LEN': LEN, Length of a character entity * `LEN_TRIM': LEN_TRIM, Length of a character entity without trailing blank characters ! * `LGAMMA': LGAMMA, Logarithm of the Gamma function * `LGE': LGE, Lexical greater than or equal * `LGT': LGT, Lexical greater than * `LINK': LINK, Create a hard link --- 2650,2659 ---- * `KILL': KILL, Send a signal to a process * `KIND': KIND, Kind of an entity * `LBOUND': LBOUND, Lower dimension bounds of an array + * `LEADZ': LEADZ, Number of leading zero bits of an integer * `LEN': LEN, Length of a character entity * `LEN_TRIM': LEN_TRIM, Length of a character entity without trailing blank characters ! * `LOG_GAMMA': LOG_GAMMA, Logarithm of the Gamma function * `LGE': LGE, Lexical greater than or equal * `LGT': LGT, Lexical greater than * `LINK': LINK, Create a hard link *************** File: gfortran.info, Node: Intrinsic Pr *** 2303,2309 **** * `RANDOM_NUMBER': RANDOM_NUMBER, Pseudo-random number * `RANDOM_SEED': RANDOM_SEED, Initialize a pseudo-random number sequence * `RAND': RAND, Real pseudo-random number ! * `RANGE': RANGE, Decimal exponent range of a real kind * `RAN': RAN, Real pseudo-random number * `REAL': REAL, Convert to real type * `RENAME': RENAME, Rename a file --- 2700,2706 ---- * `RANDOM_NUMBER': RANDOM_NUMBER, Pseudo-random number * `RANDOM_SEED': RANDOM_SEED, Initialize a pseudo-random number sequence * `RAND': RAND, Real pseudo-random number ! * `RANGE': RANGE, Decimal exponent range * `RAN': RAN, Real pseudo-random number * `REAL': REAL, Convert to real type * `RENAME': RENAME, Rename a file *************** File: gfortran.info, Node: Intrinsic Pr *** 2315,2320 **** --- 2712,2718 ---- * `SCAN': SCAN, Scan a string for the presence of a set of characters * `SECNDS': SECNDS, Time function * `SECOND': SECOND, CPU time function + * `SELECTED_CHAR_KIND': SELECTED_CHAR_KIND, Choose character kind * `SELECTED_INT_KIND': SELECTED_INT_KIND, Choose integer kind * `SELECTED_REAL_KIND': SELECTED_REAL_KIND, Choose real kind * `SET_EXPONENT': SET_EXPONENT, Set the exponent of the model *************** File: gfortran.info, Node: Intrinsic Pr *** 2341,2346 **** --- 2739,2745 ---- * `TIME': TIME, Time function * `TIME8': TIME8, Time function (64-bit) * `TINY': TINY, Smallest positive number of a real kind + * `TRAILZ': TRAILZ, Number of trailing zero bits of an integer * `TRANSFER': TRANSFER, Transfer bit patterns * `TRANSPOSE': TRANSPOSE, Transpose an array of rank two * `TRIM': TRIM, Remove trailing blank characters of a string *************** File: gfortran.info, Node: Intrinsic Pr *** 2355,2370 ****  File: gfortran.info, Node: Introduction to Intrinsics, Next: ABORT, Up: Intrinsic Procedures ! 6.1 Introduction to intrinsic procedures ======================================== The intrinsic procedures provided by GNU Fortran include all of the intrinsic procedures required by the Fortran 95 standard, a set of ! intrinsic procedures for backwards compatibility with G77, and a small ! selection of intrinsic procedures from the Fortran 2003 standard. Any ! conflict between a description here and a description in either the ! Fortran 95 standard or the Fortran 2003 standard is unintentional, and ! the standard(s) should be considered authoritative. The enumeration of the `KIND' type parameter is processor defined in the Fortran 95 standard. GNU Fortran defines the default integer type --- 2754,2770 ----  File: gfortran.info, Node: Introduction to Intrinsics, Next: ABORT, Up: Intrinsic Procedures ! 7.1 Introduction to intrinsic procedures ======================================== The intrinsic procedures provided by GNU Fortran include all of the intrinsic procedures required by the Fortran 95 standard, a set of ! intrinsic procedures for backwards compatibility with G77, and a ! selection of intrinsic procedures from the Fortran 2003 and Fortran 2008 ! standards. Any conflict between a description here and a description in ! either the Fortran 95 standard, the Fortran 2003 standard or the Fortran ! 2008 standard is unintentional, and the standard(s) should be considered ! authoritative. The enumeration of the `KIND' type parameter is processor defined in the Fortran 95 standard. GNU Fortran defines the default integer type *************** for each intrinsic procedure is noted. *** 2397,2409 ****  File: gfortran.info, Node: ABORT, Next: ABS, Prev: Introduction to Intrinsics, Up: Intrinsic Procedures ! 6.2 `ABORT' -- Abort the program ================================ _Description_: `ABORT' causes immediate termination of the program. On operating ! systems that support a core dump, `ABORT' will produce a core dump, ! which is suitable for debugging purposes. _Standard_: GNU extension --- 2797,2810 ----  File: gfortran.info, Node: ABORT, Next: ABS, Prev: Introduction to Intrinsics, Up: Intrinsic Procedures ! 7.2 `ABORT' -- Abort the program ================================ _Description_: `ABORT' causes immediate termination of the program. On operating ! systems that support a core dump, `ABORT' will produce a core dump ! even if the option `-fno-dump-core' is in effect, which is ! suitable for debugging purposes. _Standard_: GNU extension *************** _See also_: *** 2430,2457 ****  File: gfortran.info, Node: ABS, Next: ACCESS, Prev: ABORT, Up: Intrinsic Procedures ! 6.3 `ABS' -- Absolute value =========================== _Description_: ! `ABS(X)' computes the absolute value of `X'. _Standard_: ! F77 and later, has overloads that are GNU extensions _Class_: Elemental function _Syntax_: ! `RESULT = ABS(X)' _Arguments_: ! X The type of the argument shall be an ! `INTEGER(*)', `REAL(*)', or `COMPLEX(*)'. _Return value_: The return value is of the same type and kind as the argument ! except the return value is `REAL(*)' for a `COMPLEX(*)' argument. _Example_: program test_abs --- 2831,2858 ----  File: gfortran.info, Node: ABS, Next: ACCESS, Prev: ABORT, Up: Intrinsic Procedures ! 7.3 `ABS' -- Absolute value =========================== _Description_: ! `ABS(A)' computes the absolute value of `A'. _Standard_: ! Fortran 77 and later, has overloads that are GNU extensions _Class_: Elemental function _Syntax_: ! `RESULT = ABS(A)' _Arguments_: ! A The type of the argument shall be an `INTEGER', ! `REAL', or `COMPLEX'. _Return value_: The return value is of the same type and kind as the argument ! except the return value is `REAL' for a `COMPLEX' argument. _Example_: program test_abs *************** _Example_: *** 2465,2485 **** _Specific names_: Name Argument Return type Standard ! `CABS(Z)' `COMPLEX(4) `REAL(4)' F77 and later ! Z' ! `DABS(X)' `REAL(8) `REAL(8)' F77 and later ! X' ! `IABS(I)' `INTEGER(4) `INTEGER(4)' F77 and later ! I' ! `ZABS(Z)' `COMPLEX(8) `COMPLEX(8)' GNU extension Z' ! `CDABS(Z)' `COMPLEX(8) `COMPLEX(8)' GNU extension Z'  File: gfortran.info, Node: ACCESS, Next: ACHAR, Prev: ABS, Up: Intrinsic Procedures ! 6.4 `ACCESS' -- Checks file access modes ======================================== _Description_: --- 2866,2886 ---- _Specific names_: Name Argument Return type Standard ! `CABS(A)' `COMPLEX(4) `REAL(4)' Fortran 77 and ! Z' later ! `DABS(A)' `REAL(8) `REAL(8)' Fortran 77 and ! X' later ! `IABS(A)' `INTEGER(4) `INTEGER(4)' Fortran 77 and ! I' later ! `ZABS(A)' `COMPLEX(8) `COMPLEX(8)' GNU extension Z' ! `CDABS(A)' `COMPLEX(8) `COMPLEX(8)' GNU extension Z'  File: gfortran.info, Node: ACCESS, Next: ACHAR, Prev: ABS, Up: Intrinsic Procedures ! 7.4 `ACCESS' -- Checks file access modes ======================================== _Description_: *************** _Syntax_: *** 2497,2511 **** `RESULT = ACCESS(NAME, MODE)' _Arguments_: ! NAME Scalar `CHARACTER' with the file name. ! Tailing blank are ignored unless the character ! `achar(0)' is present, then all characters up ! to and excluding `achar(0)' are used as file ! name. ! MODE Scalar `CHARACTER' with the file access mode, ! may be any concatenation of `"r"' (readable), ! `"w"' (writable) and `"x"' (executable), or `" ! "' to check for existence. _Return value_: Returns a scalar `INTEGER', which is `0' if the file is accessible --- 2898,2912 ---- `RESULT = ACCESS(NAME, MODE)' _Arguments_: ! NAME Scalar `CHARACTER' of default kind with the ! file name. Tailing blank are ignored unless ! the character `achar(0)' is present, then all ! characters up to and excluding `achar(0)' are ! used as file name. ! MODE Scalar `CHARACTER' of default kind with the ! file access mode, may be any concatenation of ! `"r"' (readable), `"w"' (writable) and `"x"' ! (executable), or `" "' to check for existence. _Return value_: Returns a scalar `INTEGER', which is `0' if the file is accessible *************** _See also_: *** 2532,2538 ****  File: gfortran.info, Node: ACHAR, Next: ACOS, Prev: ACCESS, Up: Intrinsic Procedures ! 6.5 `ACHAR' -- Character in ASCII collating sequence ==================================================== _Description_: --- 2933,2939 ----  File: gfortran.info, Node: ACHAR, Next: ACOS, Prev: ACCESS, Up: Intrinsic Procedures ! 7.5 `ACHAR' -- Character in ASCII collating sequence ==================================================== _Description_: *************** _Description_: *** 2540,2559 **** ASCII collating sequence. _Standard_: ! F77 and later _Class_: Elemental function _Syntax_: ! `RESULT = ACHAR(I)' _Arguments_: ! I The type shall be `INTEGER(*)'. _Return value_: ! The return value is of type `CHARACTER' with a length of one. The ! kind type parameter is the same as `KIND('A')'. _Example_: program test_achar --- 2941,2964 ---- ASCII collating sequence. _Standard_: ! Fortran 77 and later, with KIND argument Fortran 2003 and later _Class_: Elemental function _Syntax_: ! `RESULT = ACHAR(I [, KIND])' _Arguments_: ! I The type shall be `INTEGER'. ! KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: ! The return value is of type `CHARACTER' with a length of one. If ! the KIND argument is present, the return value is of the specified ! kind and of the default kind otherwise. _Example_: program test_achar *************** _See also_: *** 2572,2585 ****  File: gfortran.info, Node: ACOS, Next: ACOSH, Prev: ACHAR, Up: Intrinsic Procedures ! 6.6 `ACOS' -- Arccosine function ================================ _Description_: `ACOS(X)' computes the arccosine of X (inverse of `COS(X)'). _Standard_: ! F77 and later _Class_: Elemental function --- 2977,2990 ----  File: gfortran.info, Node: ACOS, Next: ACOSH, Prev: ACHAR, Up: Intrinsic Procedures ! 7.6 `ACOS' -- Arccosine function ================================ _Description_: `ACOS(X)' computes the arccosine of X (inverse of `COS(X)'). _Standard_: ! Fortran 77 and later _Class_: Elemental function *************** _Syntax_: *** 2588,2599 **** `RESULT = ACOS(X)' _Arguments_: ! X The type shall be `REAL(*)' with a magnitude ! that is less than one. _Return value_: ! The return value is of type `REAL(*)' and it lies in the range 0 ! \leq \acos(x) \leq \pi. The kind type parameter is the same as X. _Example_: program test_acos --- 2993,3004 ---- `RESULT = ACOS(X)' _Arguments_: ! X The type shall be `REAL' with a magnitude that ! is less than or equal to one. _Return value_: ! The return value is of type `REAL' and it lies in the range 0 ! \leq \acos(x) \leq \pi. The return value if of the same kind as X. _Example_: program test_acos *************** _Example_: *** 2603,2609 **** _Specific names_: Name Argument Return type Standard ! `DACOS(X)' `REAL(8) X' `REAL(8)' F77 and later _See also_: Inverse function: *note COS:: --- 3008,3015 ---- _Specific names_: Name Argument Return type Standard ! `DACOS(X)' `REAL(8) X' `REAL(8)' Fortran 77 and ! later _See also_: Inverse function: *note COS:: *************** _See also_: *** 2612,2618 ****  File: gfortran.info, Node: ACOSH, Next: ADJUSTL, Prev: ACOS, Up: Intrinsic Procedures ! 6.7 `ACOSH' -- Hyperbolic arccosine function ============================================ _Description_: --- 3018,3024 ----  File: gfortran.info, Node: ACOSH, Next: ADJUSTL, Prev: ACOS, Up: Intrinsic Procedures ! 7.7 `ACOSH' -- Hyperbolic arccosine function ============================================ _Description_: *************** _Description_: *** 2620,2626 **** `COSH(X)'). _Standard_: ! GNU extension _Class_: Elemental function --- 3026,3032 ---- `COSH(X)'). _Standard_: ! Fortran 2008 and later _Class_: Elemental function *************** _Syntax_: *** 2629,2640 **** `RESULT = ACOSH(X)' _Arguments_: ! X The type shall be `REAL(*)' with a magnitude ! that is greater or equal to one. _Return value_: ! The return value is of type `REAL(*)' and it lies in the range 0 ! \leq \acosh (x) \leq \infty. _Example_: PROGRAM test_acosh --- 3035,3044 ---- `RESULT = ACOSH(X)' _Arguments_: ! X The type shall be `REAL' or `COMPLEX'. _Return value_: ! The return value has the same type and kind as X _Example_: PROGRAM test_acosh *************** _See also_: *** 2652,2680 ****  File: gfortran.info, Node: ADJUSTL, Next: ADJUSTR, Prev: ACOSH, Up: Intrinsic Procedures ! 6.8 `ADJUSTL' -- Left adjust a string ===================================== _Description_: ! `ADJUSTL(STR)' will left adjust a string by removing leading spaces. Spaces are inserted at the end of the string as needed. _Standard_: ! F95 and later _Class_: Elemental function _Syntax_: ! `RESULT = ADJUSTL(STR)' _Arguments_: ! STR The type shall be `CHARACTER'. _Return value_: ! The return value is of type `CHARACTER' where leading spaces are ! removed and the same number of spaces are inserted on the end of ! STR. _Example_: program test_adjustl --- 3056,3084 ----  File: gfortran.info, Node: ADJUSTL, Next: ADJUSTR, Prev: ACOSH, Up: Intrinsic Procedures ! 7.8 `ADJUSTL' -- Left adjust a string ===================================== _Description_: ! `ADJUSTL(STRING)' will left adjust a string by removing leading spaces. Spaces are inserted at the end of the string as needed. _Standard_: ! Fortran 90 and later _Class_: Elemental function _Syntax_: ! `RESULT = ADJUSTL(STRING)' _Arguments_: ! STRING The type shall be `CHARACTER'. _Return value_: ! The return value is of type `CHARACTER' and of the same kind as ! STRING where leading spaces are removed and the same number of ! spaces are inserted on the end of STRING. _Example_: program test_adjustl *************** _See also_: *** 2689,2717 ****  File: gfortran.info, Node: ADJUSTR, Next: AIMAG, Prev: ADJUSTL, Up: Intrinsic Procedures ! 6.9 `ADJUSTR' -- Right adjust a string ====================================== _Description_: ! `ADJUSTR(STR)' will right adjust a string by removing trailing spaces. Spaces are inserted at the start of the string as needed. _Standard_: ! F95 and later _Class_: Elemental function _Syntax_: ! `RESULT = ADJUSTR(STR)' _Arguments_: STR The type shall be `CHARACTER'. _Return value_: ! The return value is of type `CHARACTER' where trailing spaces are ! removed and the same number of spaces are inserted at the start of ! STR. _Example_: program test_adjustr --- 3093,3121 ----  File: gfortran.info, Node: ADJUSTR, Next: AIMAG, Prev: ADJUSTL, Up: Intrinsic Procedures ! 7.9 `ADJUSTR' -- Right adjust a string ====================================== _Description_: ! `ADJUSTR(STRING)' will right adjust a string by removing trailing spaces. Spaces are inserted at the start of the string as needed. _Standard_: ! Fortran 95 and later _Class_: Elemental function _Syntax_: ! `RESULT = ADJUSTR(STRING)' _Arguments_: STR The type shall be `CHARACTER'. _Return value_: ! The return value is of type `CHARACTER' and of the same kind as ! STRING where trailing spaces are removed and the same number of ! spaces are inserted at the start of STRING. _Example_: program test_adjustr *************** _See also_: *** 2726,2732 ****  File: gfortran.info, Node: AIMAG, Next: AINT, Prev: ADJUSTR, Up: Intrinsic Procedures ! 6.10 `AIMAG' -- Imaginary part of complex number ================================================ _Description_: --- 3130,3136 ----  File: gfortran.info, Node: AIMAG, Next: AINT, Prev: ADJUSTR, Up: Intrinsic Procedures ! 7.10 `AIMAG' -- Imaginary part of complex number ================================================ _Description_: *************** _Description_: *** 2736,2742 **** discouraged. _Standard_: ! F77 and later, has overloads that are GNU extensions _Class_: Elemental function --- 3140,3146 ---- discouraged. _Standard_: ! Fortran 77 and later, has overloads that are GNU extensions _Class_: Elemental function *************** _Syntax_: *** 2745,2754 **** `RESULT = AIMAG(Z)' _Arguments_: ! Z The type of the argument shall be `COMPLEX(*)'. _Return value_: ! The return value is of type real with the kind type parameter of the argument. _Example_: --- 3149,3158 ---- `RESULT = AIMAG(Z)' _Arguments_: ! Z The type of the argument shall be `COMPLEX'. _Return value_: ! The return value is of type `REAL' with the kind type parameter of the argument. _Example_: *************** _Specific names_: *** 2764,2806 **** Name Argument Return type Standard `DIMAG(Z)' `COMPLEX(8) `REAL(8)' GNU extension Z' ! `IMAG(Z)' `COMPLEX(*) `REAL(*)' GNU extension ! Z' ! `IMAGPART(Z)' `COMPLEX(*) `REAL(*)' GNU extension ! Z'  File: gfortran.info, Node: AINT, Next: ALARM, Prev: AIMAG, Up: Intrinsic Procedures ! 6.11 `AINT' -- Truncate to a whole number ========================================= _Description_: ! `AINT(X [, KIND])' truncates its argument to a whole number. _Standard_: ! F77 and later _Class_: Elemental function _Syntax_: ! `RESULT = AINT(X [, KIND])' _Arguments_: ! X The type of the argument shall be `REAL(*)'. ! KIND (Optional) An `INTEGER(*)' initialization ! expression indicating the kind ! parameter of the result. _Return value_: ! The return value is of type real with the kind type parameter of the argument if the optional KIND is absent; otherwise, the kind type parameter will be given by KIND. If the magnitude of X is ! less than one, then `AINT(X)' returns zero. If the magnitude is ! equal to or greater than one, then it returns the largest whole ! number that does not exceed its magnitude. The sign is the same ! as the sign of X. _Example_: program test_aint --- 3168,3208 ---- Name Argument Return type Standard `DIMAG(Z)' `COMPLEX(8) `REAL(8)' GNU extension Z' ! `IMAG(Z)' `COMPLEX Z' `REAL' GNU extension ! `IMAGPART(Z)' `COMPLEX Z' `REAL' GNU extension  File: gfortran.info, Node: AINT, Next: ALARM, Prev: AIMAG, Up: Intrinsic Procedures ! 7.11 `AINT' -- Truncate to a whole number ========================================= _Description_: ! `AINT(A [, KIND])' truncates its argument to a whole number. _Standard_: ! Fortran 77 and later _Class_: Elemental function _Syntax_: ! `RESULT = AINT(A [, KIND])' _Arguments_: ! A The type of the argument shall be `REAL'. ! KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: ! The return value is of type `REAL' with the kind type parameter of the argument if the optional KIND is absent; otherwise, the kind type parameter will be given by KIND. If the magnitude of X is ! less than one, `AINT(X)' returns zero. If the magnitude is equal ! to or greater than one then it returns the largest whole number ! that does not exceed its magnitude. The sign is the same as the ! sign of X. _Example_: program test_aint *************** _Example_: *** 2814,2825 **** _Specific names_: Name Argument Return type Standard ! `DINT(X)' `REAL(8) X' `REAL(8)' F77 and later  File: gfortran.info, Node: ALARM, Next: ALL, Prev: AINT, Up: Intrinsic Procedures ! 6.12 `ALARM' -- Execute a routine after a given delay ===================================================== _Description_: --- 3216,3228 ---- _Specific names_: Name Argument Return type Standard ! `DINT(X)' `REAL(8) X' `REAL(8)' Fortran 77 and ! later  File: gfortran.info, Node: ALARM, Next: ALL, Prev: AINT, Up: Intrinsic Procedures ! 7.12 `ALARM' -- Execute a routine after a given delay ===================================================== _Description_: *************** _Example_: *** 2866,2872 ****  File: gfortran.info, Node: ALL, Next: ALLOCATED, Prev: ALARM, Up: Intrinsic Procedures ! 6.13 `ALL' -- All values in MASK along DIM are true =================================================== _Description_: --- 3269,3275 ----  File: gfortran.info, Node: ALL, Next: ALLOCATED, Prev: ALARM, Up: Intrinsic Procedures ! 7.13 `ALL' -- All values in MASK along DIM are true =================================================== _Description_: *************** _Description_: *** 2874,2880 **** in the array along dimension DIM. _Standard_: ! F95 and later _Class_: Transformational function --- 3277,3283 ---- in the array along dimension DIM. _Standard_: ! Fortran 95 and later _Class_: Transformational function *************** _Syntax_: *** 2883,2896 **** `RESULT = ALL(MASK [, DIM])' _Arguments_: ! MASK The type of the argument shall be `LOGICAL(*)' ! and it shall not be scalar. DIM (Optional) DIM shall be a scalar integer with a value that lies between one and the rank of MASK. _Return value_: ! `ALL(MASK)' returns a scalar value of type `LOGICAL(*)' where the kind type parameter is the same as the kind type parameter of MASK. If DIM is present, then `ALL(MASK, DIM)' returns an array with the rank of MASK minus 1. The shape is determined from the --- 3286,3299 ---- `RESULT = ALL(MASK [, DIM])' _Arguments_: ! MASK The type of the argument shall be `LOGICAL' and ! it shall not be scalar. DIM (Optional) DIM shall be a scalar integer with a value that lies between one and the rank of MASK. _Return value_: ! `ALL(MASK)' returns a scalar value of type `LOGICAL' where the kind type parameter is the same as the kind type parameter of MASK. If DIM is present, then `ALL(MASK, DIM)' returns an array with the rank of MASK minus 1. The shape is determined from the *************** _Example_: *** 2926,2965 ****  File: gfortran.info, Node: ALLOCATED, Next: AND, Prev: ALL, Up: Intrinsic Procedures ! 6.14 `ALLOCATED' -- Status of an allocatable entity =================================================== _Description_: ! `ALLOCATED(X)' checks the status of whether X is allocated. _Standard_: ! F95 and later _Class_: Inquiry function _Syntax_: ! `RESULT = ALLOCATED(X)' _Arguments_: ! X The argument shall be an `ALLOCATABLE' array. _Return value_: The return value is a scalar `LOGICAL' with the default logical ! kind type parameter. If X is allocated, `ALLOCATED(X)' is `.TRUE.'; otherwise, it returns `.FALSE.' _Example_: program test_allocated integer :: i = 4 real(4), allocatable :: x(:) ! if (allocated(x) .eqv. .false.) allocate(x(i)) end program test_allocated  File: gfortran.info, Node: AND, Next: ANINT, Prev: ALLOCATED, Up: Intrinsic Procedures ! 6.15 `AND' -- Bitwise logical AND ================================= _Description_: --- 3329,3368 ----  File: gfortran.info, Node: ALLOCATED, Next: AND, Prev: ALL, Up: Intrinsic Procedures ! 7.14 `ALLOCATED' -- Status of an allocatable entity =================================================== _Description_: ! `ALLOCATED(ARRAY)' checks the status of whether X is allocated. _Standard_: ! Fortran 95 and later _Class_: Inquiry function _Syntax_: ! `RESULT = ALLOCATED(ARRAY)' _Arguments_: ! ARRAY The argument shall be an `ALLOCATABLE' array. _Return value_: The return value is a scalar `LOGICAL' with the default logical ! kind type parameter. If ARRAY is allocated, `ALLOCATED(ARRAY)' is `.TRUE.'; otherwise, it returns `.FALSE.' _Example_: program test_allocated integer :: i = 4 real(4), allocatable :: x(:) ! if (.not. allocated(x)) allocate(x(i)) end program test_allocated  File: gfortran.info, Node: AND, Next: ANINT, Prev: ALLOCATED, Up: Intrinsic Procedures ! 7.15 `AND' -- Bitwise logical AND ================================= _Description_: *************** _Syntax_: *** 2980,2993 **** `RESULT = AND(I, J)' _Arguments_: ! I The type shall be either `INTEGER(*)' or ! `LOGICAL'. ! J The type shall be either `INTEGER(*)' or ! `LOGICAL'. _Return value_: ! The return type is either `INTEGER(*)' or `LOGICAL' after ! cross-promotion of the arguments. _Example_: PROGRAM test_and --- 3383,3397 ---- `RESULT = AND(I, J)' _Arguments_: ! I The type shall be either a scalar `INTEGER' ! type or a scalar `LOGICAL' type. ! J The type shall be the same as the type of I. _Return value_: ! The return type is either a scalar `INTEGER' or a scalar ! `LOGICAL'. If the kind type parameters differ, then the smaller ! kind type is implicitly converted to larger kind, and the return ! has the larger kind. _Example_: PROGRAM test_and *************** _Example_: *** 3000,3038 **** END PROGRAM _See also_: ! F95 elemental function: *note IAND::  File: gfortran.info, Node: ANINT, Next: ANY, Prev: AND, Up: Intrinsic Procedures ! 6.16 `ANINT' -- Nearest whole number ==================================== _Description_: ! `ANINT(X [, KIND])' rounds its argument to the nearest whole number. _Standard_: ! F77 and later _Class_: Elemental function _Syntax_: ! `RESULT = ANINT(X [, KIND])' _Arguments_: ! X The type of the argument shall be `REAL(*)'. ! KIND (Optional) An `INTEGER(*)' initialization ! expression indicating the kind ! parameter of the result. _Return value_: The return value is of type real with the kind type parameter of the argument if the optional KIND is absent; otherwise, the kind ! type parameter will be given by KIND. If X is greater than zero, ! then `ANINT(X)' returns `AINT(X+0.5)'. If X is less than or equal ! to zero, then it returns `AINT(X-0.5)'. _Example_: program test_anint --- 3404,3442 ---- END PROGRAM _See also_: ! Fortran 95 elemental function: *note IAND::  File: gfortran.info, Node: ANINT, Next: ANY, Prev: AND, Up: Intrinsic Procedures ! 7.16 `ANINT' -- Nearest whole number ==================================== _Description_: ! `ANINT(A [, KIND])' rounds its argument to the nearest whole number. _Standard_: ! Fortran 77 and later _Class_: Elemental function _Syntax_: ! `RESULT = ANINT(A [, KIND])' _Arguments_: ! A The type of the argument shall be `REAL'. ! KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: The return value is of type real with the kind type parameter of the argument if the optional KIND is absent; otherwise, the kind ! type parameter will be given by KIND. If A is greater than zero, ! `ANINT(A)' returns `AINT(X+0.5)'. If A is less than or equal to ! zero then it returns `AINT(X-0.5)'. _Example_: program test_anint *************** _Example_: *** 3046,3057 **** _Specific names_: Name Argument Return type Standard ! `DNINT(X)' `REAL(8) X' `REAL(8)' F77 and later  File: gfortran.info, Node: ANY, Next: ASIN, Prev: ANINT, Up: Intrinsic Procedures ! 6.17 `ANY' -- Any value in MASK along DIM is true ================================================= _Description_: --- 3450,3462 ---- _Specific names_: Name Argument Return type Standard ! `DNINT(A)' `REAL(8) A' `REAL(8)' Fortran 77 and ! later  File: gfortran.info, Node: ANY, Next: ASIN, Prev: ANINT, Up: Intrinsic Procedures ! 7.17 `ANY' -- Any value in MASK along DIM is true ================================================= _Description_: *************** _Description_: *** 3059,3065 **** array MASK along dimension DIM are `.TRUE.'. _Standard_: ! F95 and later _Class_: Transformational function --- 3464,3470 ---- array MASK along dimension DIM are `.TRUE.'. _Standard_: ! Fortran 95 and later _Class_: Transformational function *************** _Syntax_: *** 3068,3081 **** `RESULT = ANY(MASK [, DIM])' _Arguments_: ! MASK The type of the argument shall be `LOGICAL(*)' ! and it shall not be scalar. DIM (Optional) DIM shall be a scalar integer with a value that lies between one and the rank of MASK. _Return value_: ! `ANY(MASK)' returns a scalar value of type `LOGICAL(*)' where the kind type parameter is the same as the kind type parameter of MASK. If DIM is present, then `ANY(MASK, DIM)' returns an array with the rank of MASK minus 1. The shape is determined from the --- 3473,3486 ---- `RESULT = ANY(MASK [, DIM])' _Arguments_: ! MASK The type of the argument shall be `LOGICAL' and ! it shall not be scalar. DIM (Optional) DIM shall be a scalar integer with a value that lies between one and the rank of MASK. _Return value_: ! `ANY(MASK)' returns a scalar value of type `LOGICAL' where the kind type parameter is the same as the kind type parameter of MASK. If DIM is present, then `ANY(MASK, DIM)' returns an array with the rank of MASK minus 1. The shape is determined from the *************** _Example_: *** 3112,3125 ****  File: gfortran.info, Node: ASIN, Next: ASINH, Prev: ANY, Up: Intrinsic Procedures ! 6.18 `ASIN' -- Arcsine function =============================== _Description_: `ASIN(X)' computes the arcsine of its X (inverse of `SIN(X)'). _Standard_: ! F77 and later _Class_: Elemental function --- 3517,3530 ----  File: gfortran.info, Node: ASIN, Next: ASINH, Prev: ANY, Up: Intrinsic Procedures ! 7.18 `ASIN' -- Arcsine function =============================== _Description_: `ASIN(X)' computes the arcsine of its X (inverse of `SIN(X)'). _Standard_: ! Fortran 77 and later _Class_: Elemental function *************** _Syntax_: *** 3128,3140 **** `RESULT = ASIN(X)' _Arguments_: ! X The type shall be `REAL(*)', and a magnitude ! that is less than one. _Return value_: ! The return value is of type `REAL(*)' and it lies in the range ! -\pi / 2 \leq \asin (x) \leq \pi / 2. The kind type parameter is ! the same as X. _Example_: program test_asin --- 3533,3545 ---- `RESULT = ASIN(X)' _Arguments_: ! X The type shall be `REAL', and a magnitude that ! is less than or equal to one. _Return value_: ! The return value is of type `REAL' and it lies in the range -\pi / ! 2 \leq \asin (x) \leq \pi / 2. The kind type parameter is the ! same as X. _Example_: program test_asin *************** _Example_: *** 3144,3150 **** _Specific names_: Name Argument Return type Standard ! `DASIN(X)' `REAL(8) X' `REAL(8)' F77 and later _See also_: Inverse function: *note SIN:: --- 3549,3556 ---- _Specific names_: Name Argument Return type Standard ! `DASIN(X)' `REAL(8) X' `REAL(8)' Fortran 77 and ! later _See also_: Inverse function: *note SIN:: *************** _See also_: *** 3153,3159 ****  File: gfortran.info, Node: ASINH, Next: ASSOCIATED, Prev: ASIN, Up: Intrinsic Procedures ! 6.19 `ASINH' -- Hyperbolic arcsine function =========================================== _Description_: --- 3559,3565 ----  File: gfortran.info, Node: ASINH, Next: ASSOCIATED, Prev: ASIN, Up: Intrinsic Procedures ! 7.19 `ASINH' -- Hyperbolic arcsine function =========================================== _Description_: *************** _Description_: *** 3161,3167 **** `SINH(X)'). _Standard_: ! GNU extension _Class_: Elemental function --- 3567,3573 ---- `SINH(X)'). _Standard_: ! Fortran 2008 and later _Class_: Elemental function *************** _Syntax_: *** 3170,3181 **** `RESULT = ASINH(X)' _Arguments_: ! X The type shall be `REAL(*)', with X a real ! number. _Return value_: ! The return value is of type `REAL(*)' and it lies in the range ! -\infty \leq \asinh (x) \leq \infty. _Example_: PROGRAM test_asinh --- 3576,3585 ---- `RESULT = ASINH(X)' _Arguments_: ! X The type shall be `REAL' or `COMPLEX'. _Return value_: ! The return value is of the same type and kind as X. _Example_: PROGRAM test_asinh *************** _See also_: *** 3193,3253 ****  File: gfortran.info, Node: ASSOCIATED, Next: ATAN, Prev: ASINH, Up: Intrinsic Procedures ! 6.20 `ASSOCIATED' -- Status of a pointer or pointer/target pair =============================================================== _Description_: ! `ASSOCIATED(PTR [, TGT])' determines the status of the pointer PTR ! or if PTR is associated with the target TGT. _Standard_: ! F95 and later _Class_: Inquiry function _Syntax_: ! `RESULT = ASSOCIATED(PTR [, TGT])' _Arguments_: ! PTR PTR shall have the `POINTER' attribute and it ! can be of any type. ! TGT (Optional) TGT shall be a `POINTER' or a ! `TARGET'. It must have the same type, kind ! type parameter, and array rank as PTR. ! The status of neither PTR nor TGT can be undefined. _Return value_: ! `ASSOCIATED(PTR)' returns a scalar value of type `LOGICAL(4)'. There are several cases: ! (A) If the optional TGT is not present, then `ASSOCIATED(PTR)' ! is true if PTR is associated with a target; otherwise, it ! returns false. ! (B) If TGT is present and a scalar target, the result is true if ! TGT is not a 0 sized storage sequence and the target ! associated with PTR occupies the same storage units. If PTR ! is disassociated, then the result is false. ! (C) If TGT is present and an array target, the result is true if ! TGT and PTR have the same shape, are not 0 sized arrays, are ! arrays whose elements are not 0 sized storage sequences, and ! TGT and PTR occupy the same storage units in array element ! order. As in case(B), the result is false, if PTR is ! disassociated. ! (D) If TGT is present and an scalar pointer, the result is true if ! target associated with PTR and the target associated with TGT ! are not 0 sized storage sequences and occupy the same storage ! units. The result is false, if either TGT or PTR is ! disassociated. ! (E) If TGT is present and an array pointer, the result is true if ! target associated with PTR and the target associated with TGT ! have the same shape, are not 0 sized arrays, are arrays whose ! elements are not 0 sized storage sequences, and TGT and PTR ! occupy the same storage units in array element order. The ! result is false, if either TGT or PTR is disassociated. _Example_: program test_associated --- 3597,3659 ----  File: gfortran.info, Node: ASSOCIATED, Next: ATAN, Prev: ASINH, Up: Intrinsic Procedures ! 7.20 `ASSOCIATED' -- Status of a pointer or pointer/target pair =============================================================== _Description_: ! `ASSOCIATED(POINTER [, TARGET])' determines the status of the ! pointer POINTER or if POINTER is associated with the target TARGET. _Standard_: ! Fortran 95 and later _Class_: Inquiry function _Syntax_: ! `RESULT = ASSOCIATED(POINTER [, TARGET])' _Arguments_: ! POINTER POINTER shall have the `POINTER' attribute and ! it can be of any type. ! TARGET (Optional) TARGET shall be a pointer or a ! target. It must have the same type, kind type ! parameter, and array rank as POINTER. ! The association status of neither POINTER nor TARGET shall be ! undefined. _Return value_: ! `ASSOCIATED(POINTER)' returns a scalar value of type `LOGICAL(4)'. There are several cases: ! (A) When the optional TARGET is not present then ! `ASSOCIATED(POINTER)' is true if POINTER is associated with a ! target; otherwise, it returns false. ! (B) If TARGET is present and a scalar target, the result is true if ! TARGET is not a zero-sized storage sequence and the target ! associated with POINTER occupies the same storage units. If ! POINTER is disassociated, the result is false. ! (C) If TARGET is present and an array target, the result is true if ! TARGET and POINTER have the same shape, are not zero-sized ! arrays, are arrays whose elements are not zero-sized storage ! sequences, and TARGET and POINTER occupy the same storage ! units in array element order. As in case(B), the result is ! false, if POINTER is disassociated. ! (D) If TARGET is present and an scalar pointer, the result is true ! if TARGET is associated with POINTER, the target associated ! with TARGET are not zero-sized storage sequences and occupy ! the same storage units. The result is false, if either ! TARGET or POINTER is disassociated. ! (E) If TARGET is present and an array pointer, the result is true if ! target associated with POINTER and the target associated with ! TARGET have the same shape, are not zero-sized arrays, are ! arrays whose elements are not zero-sized storage sequences, ! and TARGET and POINTER occupy the same storage units in array ! element order. The result is false, if either TARGET or ! POINTER is disassociated. _Example_: program test_associated *************** _See also_: *** 3265,3278 ****  File: gfortran.info, Node: ATAN, Next: ATAN2, Prev: ASSOCIATED, Up: Intrinsic Procedures ! 6.21 `ATAN' -- Arctangent function ================================== _Description_: `ATAN(X)' computes the arctangent of X. _Standard_: ! F77 and later _Class_: Elemental function --- 3671,3684 ----  File: gfortran.info, Node: ATAN, Next: ATAN2, Prev: ASSOCIATED, Up: Intrinsic Procedures ! 7.21 `ATAN' -- Arctangent function ================================== _Description_: `ATAN(X)' computes the arctangent of X. _Standard_: ! Fortran 77 and later _Class_: Elemental function *************** _Syntax_: *** 3281,3291 **** `RESULT = ATAN(X)' _Arguments_: ! X The type shall be `REAL(*)'. _Return value_: ! The return value is of type `REAL(*)' and it lies in the range - ! \pi / 2 \leq \atan (x) \leq \pi / 2. _Example_: program test_atan --- 3687,3697 ---- `RESULT = ATAN(X)' _Arguments_: ! X The type shall be `REAL'. _Return value_: ! The return value is of type `REAL' and it lies in the range - \pi ! / 2 \leq \atan (x) \leq \pi / 2. _Example_: program test_atan *************** _Example_: *** 3295,3301 **** _Specific names_: Name Argument Return type Standard ! `DATAN(X)' `REAL(8) X' `REAL(8)' F77 and later _See also_: Inverse function: *note TAN:: --- 3701,3708 ---- _Specific names_: Name Argument Return type Standard ! `DATAN(X)' `REAL(8) X' `REAL(8)' Fortran 77 and ! later _See also_: Inverse function: *note TAN:: *************** _See also_: *** 3304,3326 ****  File: gfortran.info, Node: ATAN2, Next: ATANH, Prev: ATAN, Up: Intrinsic Procedures ! 6.22 `ATAN2' -- Arctangent function =================================== _Description_: ! `ATAN2(Y,X)' computes the arctangent of the complex number X + i Y. _Standard_: ! F77 and later _Class_: Elemental function _Syntax_: ! `RESULT = ATAN2(Y,X)' _Arguments_: ! Y The type shall be `REAL(*)'. X The type and kind type parameter shall be the same as Y. If Y is zero, then X must be nonzero. --- 3711,3734 ----  File: gfortran.info, Node: ATAN2, Next: ATANH, Prev: ATAN, Up: Intrinsic Procedures ! 7.22 `ATAN2' -- Arctangent function =================================== _Description_: ! `ATAN2(Y, X)' computes the arctangent of the complex number X + i ! Y. _Standard_: ! Fortran 77 and later _Class_: Elemental function _Syntax_: ! `RESULT = ATAN2(Y, X)' _Arguments_: ! Y The type shall be `REAL'. X The type and kind type parameter shall be the same as Y. If Y is zero, then X must be nonzero. *************** _Example_: *** 3341,3352 **** _Specific names_: Name Argument Return type Standard ! `DATAN2(X)' `REAL(8) X' `REAL(8)' F77 and later  ! File: gfortran.info, Node: ATANH, Next: BESJ0, Prev: ATAN2, Up: Intrinsic Procedures ! 6.23 `ATANH' -- Hyperbolic arctangent function ============================================== _Description_: --- 3749,3761 ---- _Specific names_: Name Argument Return type Standard ! `DATAN2(X)' `REAL(8) X' `REAL(8)' Fortran 77 and ! later  ! File: gfortran.info, Node: ATANH, Next: BESSEL_J0, Prev: ATAN2, Up: Intrinsic Procedures ! 7.23 `ATANH' -- Hyperbolic arctangent function ============================================== _Description_: *************** _Description_: *** 3354,3360 **** `TANH(X)'). _Standard_: ! GNU extension _Class_: Elemental function --- 3763,3769 ---- `TANH(X)'). _Standard_: ! Fortran 2008 and later _Class_: Elemental function *************** _Syntax_: *** 3363,3374 **** `RESULT = ATANH(X)' _Arguments_: ! X The type shall be `REAL(*)' with a magnitude ! that is less than or equal to one. _Return value_: ! The return value is of type `REAL(*)' and it lies in the range ! -\infty \leq \atanh(x) \leq \infty. _Example_: PROGRAM test_atanh --- 3772,3781 ---- `RESULT = ATANH(X)' _Arguments_: ! X The type shall be `REAL' or `COMPLEX'. _Return value_: ! The return value has same type and kind as X. _Example_: PROGRAM test_atanh *************** _See also_: *** 3384,3419 **** Inverse function: *note TANH::  ! File: gfortran.info, Node: BESJ0, Next: BESJ1, Prev: ATANH, Up: Intrinsic Procedures ! 6.24 `BESJ0' -- Bessel function of the first kind of order 0 ! ============================================================ _Description_: ! `BESJ0(X)' computes the Bessel function of the first kind of order ! 0 of X. _Standard_: ! GNU extension _Class_: Elemental function _Syntax_: ! `RESULT = BESJ0(X)' _Arguments_: ! X The type shall be `REAL(*)', and it shall be scalar. _Return value_: ! The return value is of type `REAL(*)' and it lies in the range - ! 0.4027... \leq Bessel (0,x) \leq 1. _Example_: program test_besj0 real(8) :: x = 0.0_8 ! x = besj0(x) end program test_besj0 _Specific names_: --- 3791,3827 ---- Inverse function: *note TANH::  ! File: gfortran.info, Node: BESSEL_J0, Next: BESSEL_J1, Prev: ATANH, Up: Intrinsic Procedures ! 7.24 `BESSEL_J0' -- Bessel function of the first kind of order 0 ! ================================================================ _Description_: ! `BESSEL_J0(X)' computes the Bessel function of the first kind of ! order 0 of X. This function is available under the name `BESJ0' as ! a GNU extension. _Standard_: ! Fortran 2008 and later _Class_: Elemental function _Syntax_: ! `RESULT = BESSEL_J0(X)' _Arguments_: ! X The type shall be `REAL', and it shall be scalar. _Return value_: ! The return value is of type `REAL' and lies in the range - ! 0.4027... \leq Bessel (0,x) \leq 1. It has the same kind as X. _Example_: program test_besj0 real(8) :: x = 0.0_8 ! x = bessel_j0(x) end program test_besj0 _Specific names_: *************** _Specific names_: *** 3421,3456 **** `DBESJ0(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: BESJ1, Next: BESJN, Prev: BESJ0, Up: Intrinsic Procedures ! 6.25 `BESJ1' -- Bessel function of the first kind of order 1 ! ============================================================ _Description_: ! `BESJ1(X)' computes the Bessel function of the first kind of order ! 1 of X. _Standard_: ! GNU extension _Class_: Elemental function _Syntax_: ! `RESULT = BESJ1(X)' _Arguments_: ! X The type shall be `REAL(*)', and it shall be scalar. _Return value_: ! The return value is of type `REAL(*)' and it lies in the range - ! 0.5818... \leq Bessel (0,x) \leq 0.5818 . _Example_: program test_besj1 real(8) :: x = 1.0_8 ! x = besj1(x) end program test_besj1 _Specific names_: --- 3829,3866 ---- `DBESJ0(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: BESSEL_J1, Next: BESSEL_JN, Prev: BESSEL_J0, Up: Intrinsic Procedures ! 7.25 `BESSEL_J1' -- Bessel function of the first kind of order 1 ! ================================================================ _Description_: ! `BESSEL_J1(X)' computes the Bessel function of the first kind of ! order 1 of X. This function is available under the name `BESJ1' as ! a GNU extension. _Standard_: ! Fortran 2008 _Class_: Elemental function _Syntax_: ! `RESULT = BESSEL_J1(X)' _Arguments_: ! X The type shall be `REAL', and it shall be scalar. _Return value_: ! The return value is of type `REAL' and it lies in the range - ! 0.5818... \leq Bessel (0,x) \leq 0.5818 . It has the same kind as ! X. _Example_: program test_besj1 real(8) :: x = 1.0_8 ! x = bessel_j1(x) end program test_besj1 _Specific names_: *************** _Specific names_: *** 3458,3534 **** `DBESJ1(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: BESJN, Next: BESY0, Prev: BESJ1, Up: Intrinsic Procedures ! 6.26 `BESJN' -- Bessel function of the first kind ! ================================================= _Description_: ! `BESJN(N, X)' computes the Bessel function of the first kind of ! order N of X. If both arguments are arrays, their ranks and shapes shall conform. _Standard_: ! GNU extension _Class_: Elemental function _Syntax_: ! `RESULT = BESJN(N, X)' _Arguments_: N Shall be a scalar or an array of type ! `INTEGER(*)'. ! X Shall be a scalar or an array of type ! `REAL(*)'. _Return value_: ! The return value is a scalar of type `REAL(*)'. _Example_: program test_besjn real(8) :: x = 1.0_8 ! x = besjn(5,x) end program test_besjn _Specific names_: Name Argument Return type Standard ! `DBESJN(X)' `INTEGER(*) `REAL(8)' GNU extension ! N' `REAL(8) X'  ! File: gfortran.info, Node: BESY0, Next: BESY1, Prev: BESJN, Up: Intrinsic Procedures ! 6.27 `BESY0' -- Bessel function of the second kind of order 0 ! ============================================================= _Description_: ! `BESY0(X)' computes the Bessel function of the second kind of ! order 0 of X. _Standard_: ! GNU extension _Class_: Elemental function _Syntax_: ! `RESULT = BESY0(X)' _Arguments_: ! X The type shall be `REAL(*)', and it shall be scalar. _Return value_: ! The return value is a scalar of type `REAL(*)'. _Example_: program test_besy0 real(8) :: x = 0.0_8 ! x = besy0(x) end program test_besy0 _Specific names_: --- 3868,3946 ---- `DBESJ1(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: BESSEL_JN, Next: BESSEL_Y0, Prev: BESSEL_J1, Up: Intrinsic Procedures ! 7.26 `BESSEL_JN' -- Bessel function of the first kind ! ===================================================== _Description_: ! `BESSEL_JN(N, X)' computes the Bessel function of the first kind of ! order N of X. This function is available under the name `BESJN' as ! a GNU extension. If both arguments are arrays, their ranks and shapes shall conform. _Standard_: ! Fortran 2008 and later _Class_: Elemental function _Syntax_: ! `RESULT = BESSEL_JN(N, X)' _Arguments_: N Shall be a scalar or an array of type ! `INTEGER'. ! X Shall be a scalar or an array of type `REAL'. _Return value_: ! The return value is a scalar of type `REAL'. It has the same kind ! as X. _Example_: program test_besjn real(8) :: x = 1.0_8 ! x = bessel_jn(5,x) end program test_besjn _Specific names_: Name Argument Return type Standard ! `DBESJN(X)' `INTEGER N' `REAL(8)' GNU extension `REAL(8) X'  ! File: gfortran.info, Node: BESSEL_Y0, Next: BESSEL_Y1, Prev: BESSEL_JN, Up: Intrinsic Procedures ! 7.27 `BESSEL_Y0' -- Bessel function of the second kind of order 0 ! ================================================================= _Description_: ! `BESSEL_Y0(X)' computes the Bessel function of the second kind of ! order 0 of X. This function is available under the name `BESY0' as ! a GNU extension. _Standard_: ! Fortran 2008 and later _Class_: Elemental function _Syntax_: ! `RESULT = BESSEL_Y0(X)' _Arguments_: ! X The type shall be `REAL', and it shall be scalar. _Return value_: ! The return value is a scalar of type `REAL'. It has the same kind ! as X. _Example_: program test_besy0 real(8) :: x = 0.0_8 ! x = bessel_y0(x) end program test_besy0 _Specific names_: *************** _Specific names_: *** 3536,3570 **** `DBESY0(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: BESY1, Next: BESYN, Prev: BESY0, Up: Intrinsic Procedures ! 6.28 `BESY1' -- Bessel function of the second kind of order 1 ! ============================================================= _Description_: ! `BESY1(X)' computes the Bessel function of the second kind of ! order 1 of X. _Standard_: ! GNU extension _Class_: Elemental function _Syntax_: ! `RESULT = BESY1(X)' _Arguments_: ! X The type shall be `REAL(*)', and it shall be scalar. _Return value_: ! The return value is a scalar of type `REAL(*)'. _Example_: program test_besy1 real(8) :: x = 1.0_8 ! x = besy1(x) end program test_besy1 _Specific names_: --- 3948,3984 ---- `DBESY0(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: BESSEL_Y1, Next: BESSEL_YN, Prev: BESSEL_Y0, Up: Intrinsic Procedures ! 7.28 `BESSEL_Y1' -- Bessel function of the second kind of order 1 ! ================================================================= _Description_: ! `BESSEL_Y1(X)' computes the Bessel function of the second kind of ! order 1 of X. This function is available under the name `BESY1' as ! a GNU extension. _Standard_: ! Fortran 2008 and later _Class_: Elemental function _Syntax_: ! `RESULT = BESSEL_Y1(X)' _Arguments_: ! X The type shall be `REAL', and it shall be scalar. _Return value_: ! The return value is a scalar of type `REAL'. It has the same kind ! as X. _Example_: program test_besy1 real(8) :: x = 1.0_8 ! x = bessel_y1(x) end program test_besy1 _Specific names_: *************** _Specific names_: *** 3572,3631 **** `DBESY1(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: BESYN, Next: BIT_SIZE, Prev: BESY1, Up: Intrinsic Procedures ! 6.29 `BESYN' -- Bessel function of the second kind ! ================================================== _Description_: ! `BESYN(N, X)' computes the Bessel function of the second kind of ! order N of X. If both arguments are arrays, their ranks and shapes shall conform. _Standard_: ! GNU extension _Class_: Elemental function _Syntax_: ! `RESULT = BESYN(N, X)' _Arguments_: N Shall be a scalar or an array of type ! `INTEGER(*)'. ! X Shall be a scalar or an array of type ! `REAL(*)'. _Return value_: ! The return value is a scalar of type `REAL(*)'. _Example_: program test_besyn real(8) :: x = 1.0_8 ! x = besyn(5,x) end program test_besyn _Specific names_: Name Argument Return type Standard ! `DBESYN(N,X)' `INTEGER(*) `REAL(8)' GNU extension ! N' `REAL(8) X'  ! File: gfortran.info, Node: BIT_SIZE, Next: BTEST, Prev: BESYN, Up: Intrinsic Procedures ! 6.30 `BIT_SIZE' -- Bit size inquiry function ============================================ _Description_: `BIT_SIZE(I)' returns the number of bits (integer precision plus ! sign bit) represented by the type of I. _Standard_: ! F95 and later _Class_: Inquiry function --- 3986,4046 ---- `DBESY1(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: BESSEL_YN, Next: BIT_SIZE, Prev: BESSEL_Y1, Up: Intrinsic Procedures ! 7.29 `BESSEL_YN' -- Bessel function of the second kind ! ====================================================== _Description_: ! `BESSEL_YN(N, X)' computes the Bessel function of the second kind ! of order N of X. This function is available under the name `BESYN' ! as a GNU extension. If both arguments are arrays, their ranks and shapes shall conform. _Standard_: ! Fortran 2008 and later _Class_: Elemental function _Syntax_: ! `RESULT = BESSEL_YN(N, X)' _Arguments_: N Shall be a scalar or an array of type ! `INTEGER'. ! X Shall be a scalar or an array of type `REAL'. _Return value_: ! The return value is a scalar of type `REAL'. It has the same kind ! as X. _Example_: program test_besyn real(8) :: x = 1.0_8 ! x = bessel_yn(5,x) end program test_besyn _Specific names_: Name Argument Return type Standard ! `DBESYN(N,X)' `INTEGER N' `REAL(8)' GNU extension `REAL(8) X'  ! File: gfortran.info, Node: BIT_SIZE, Next: BTEST, Prev: BESSEL_YN, Up: Intrinsic Procedures ! 7.30 `BIT_SIZE' -- Bit size inquiry function ============================================ _Description_: `BIT_SIZE(I)' returns the number of bits (integer precision plus ! sign bit) represented by the type of I. The result of ! `BIT_SIZE(I)' is independent of the actual value of I. _Standard_: ! Fortran 95 and later _Class_: Inquiry function *************** _Syntax_: *** 3634,3643 **** `RESULT = BIT_SIZE(I)' _Arguments_: ! I The type shall be `INTEGER(*)'. _Return value_: ! The return value is of type `INTEGER(*)' _Example_: program test_bit_size --- 4049,4058 ---- `RESULT = BIT_SIZE(I)' _Arguments_: ! I The type shall be `INTEGER'. _Return value_: ! The return value is of type `INTEGER' _Example_: program test_bit_size *************** _Example_: *** 3650,3664 ****  File: gfortran.info, Node: BTEST, Next: C_ASSOCIATED, Prev: BIT_SIZE, Up: Intrinsic Procedures ! 6.31 `BTEST' -- Bit test function ================================= _Description_: `BTEST(I,POS)' returns logical `.TRUE.' if the bit at POS in I is ! set. _Standard_: ! F95 and later _Class_: Elemental function --- 4065,4079 ----  File: gfortran.info, Node: BTEST, Next: C_ASSOCIATED, Prev: BIT_SIZE, Up: Intrinsic Procedures ! 7.31 `BTEST' -- Bit test function ================================= _Description_: `BTEST(I,POS)' returns logical `.TRUE.' if the bit at POS in I is ! set. The counting of the bits starts at 0. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 3667,3674 **** `RESULT = BTEST(I, POS)' _Arguments_: ! I The type shall be `INTEGER(*)'. ! POS The type shall be `INTEGER(*)'. _Return value_: The return value is of type `LOGICAL' --- 4082,4089 ---- `RESULT = BTEST(I, POS)' _Arguments_: ! I The type shall be `INTEGER'. ! POS The type shall be `INTEGER'. _Return value_: The return value is of type `LOGICAL' *************** _Example_: *** 3687,3715 ****  File: gfortran.info, Node: C_ASSOCIATED, Next: C_F_POINTER, Prev: BTEST, Up: Intrinsic Procedures ! 6.32 `C_ASSOCIATED' -- Status of a C pointer ============================================ _Description_: ! `C_ASSOICATED(c_prt1[, c_ptr2])' determines the status of the C ! pointer C_PTR1 or if C_PTR1 is associated with the target C_PTR2. _Standard_: ! F2003 and later _Class_: Inquiry function _Syntax_: ! `RESULT = C_ASSOICATED(c_prt1[, c_ptr2])' _Arguments_: ! C_PTR1 Scalar of the type `C_PTR' or `C_FUNPTR'. ! C_PTR2 (Optional) Scalar of the same type as C_PTR1. _Return value_: The return value is of type `LOGICAL'; it is `.false.' if either ! C_PTR1 is a C NULL pointer or if C_PTR1 and C_PTR2 point to different addresses. _Example_: --- 4102,4131 ----  File: gfortran.info, Node: C_ASSOCIATED, Next: C_F_POINTER, Prev: BTEST, Up: Intrinsic Procedures ! 7.32 `C_ASSOCIATED' -- Status of a C pointer ============================================ _Description_: ! `C_ASSOCIATED(c_prt_1[, c_ptr_2])' determines the status of the C ! pointer C_PTR_1 or if C_PTR_1 is associated with the target ! C_PTR_2. _Standard_: ! Fortran 2003 and later _Class_: Inquiry function _Syntax_: ! `RESULT = C_ASSOCIATED(c_prt_1[, c_ptr_2])' _Arguments_: ! C_PTR_1 Scalar of the type `C_PTR' or `C_FUNPTR'. ! C_PTR_2 (Optional) Scalar of the same type as C_PTR_1. _Return value_: The return value is of type `LOGICAL'; it is `.false.' if either ! C_PTR_1 is a C NULL pointer or if C_PTR1 and C_PTR_2 point to different addresses. _Example_: *************** _See also_: *** 3728,3741 ****  File: gfortran.info, Node: C_FUNLOC, Next: C_LOC, Prev: C_F_PROCPOINTER, Up: Intrinsic Procedures ! 6.33 `C_FUNLOC' -- Obtain the C address of a procedure ====================================================== _Description_: `C_FUNLOC(x)' determines the C address of the argument. _Standard_: ! F2003 and later _Class_: Inquiry function --- 4144,4157 ----  File: gfortran.info, Node: C_FUNLOC, Next: C_LOC, Prev: C_F_PROCPOINTER, Up: Intrinsic Procedures ! 7.33 `C_FUNLOC' -- Obtain the C address of a procedure ====================================================== _Description_: `C_FUNLOC(x)' determines the C address of the argument. _Standard_: ! Fortran 2003 and later _Class_: Inquiry function *************** _See also_: *** 3781,3798 ****  File: gfortran.info, Node: C_F_PROCPOINTER, Next: C_FUNLOC, Prev: C_F_POINTER, Up: Intrinsic Procedures ! 6.34 `C_F_PROCPOINTER' -- Convert C into Fortran procedure pointer ================================================================== _Description_: ! `C_F_PROCPOINTER(cptr, fptr)' Assign the target of the C function pointer CPTR to the Fortran procedure pointer FPTR. Note: Due to the currently lacking support of procedure pointers in GNU Fortran this function is not fully operable. _Standard_: ! F2003 and later _Class_: Subroutine --- 4197,4214 ----  File: gfortran.info, Node: C_F_PROCPOINTER, Next: C_FUNLOC, Prev: C_F_POINTER, Up: Intrinsic Procedures ! 7.34 `C_F_PROCPOINTER' -- Convert C into Fortran procedure pointer ================================================================== _Description_: ! `C_F_PROCPOINTER(CPTR, FPTR)' Assign the target of the C function pointer CPTR to the Fortran procedure pointer FPTR. Note: Due to the currently lacking support of procedure pointers in GNU Fortran this function is not fully operable. _Standard_: ! Fortran 2003 and later _Class_: Subroutine *************** _Syntax_: *** 3802,3810 **** _Arguments_: CPTR scalar of the type `C_FUNPTR'. It is ! `INTENT(IN)'. FPTR procedure pointer interoperable with CPTR. It ! is `INTENT(OUT)'. _Example_: program main --- 4218,4226 ---- _Arguments_: CPTR scalar of the type `C_FUNPTR'. It is ! `INTENT(IN)'. FPTR procedure pointer interoperable with CPTR. It ! is `INTENT(OUT)'. _Example_: program main *************** _See also_: *** 3835,3866 ****  File: gfortran.info, Node: C_F_POINTER, Next: C_F_PROCPOINTER, Prev: C_ASSOCIATED, Up: Intrinsic Procedures ! 6.35 `C_F_POINTER' -- Convert C into Fortran pointer ==================================================== _Description_: ! `C_F_POINTER(cptr, fptr[, shape])' Assign the target the C pointer CPTR to the Fortran pointer FPTR and specify its shape. _Standard_: ! F2003 and later _Class_: Subroutine _Syntax_: ! `CALL C_F_POINTER(cptr, fptr[, shape])' _Arguments_: ! CPTR scalar of the type `C_PTR'. It is ! `INTENT(IN)'. FPTR pointer interoperable with CPTR. It is ! `INTENT(OUT)'. SHAPE (Optional) Rank-one array of type `INTEGER' ! with `INTENT(IN)'. It shall ! be present if and only if ! FPTR is an array. The size ! must be equal to the rank of FPTR. _Example_: program main --- 4251,4280 ----  File: gfortran.info, Node: C_F_POINTER, Next: C_F_PROCPOINTER, Prev: C_ASSOCIATED, Up: Intrinsic Procedures ! 7.35 `C_F_POINTER' -- Convert C into Fortran pointer ==================================================== _Description_: ! `C_F_POINTER(CPTR, FPTR[, SHAPE])' Assign the target the C pointer CPTR to the Fortran pointer FPTR and specify its shape. _Standard_: ! Fortran 2003 and later _Class_: Subroutine _Syntax_: ! `CALL C_F_POINTER(CPTR, FPTR[, SHAPE])' _Arguments_: ! CPTR scalar of the type `C_PTR'. It is `INTENT(IN)'. FPTR pointer interoperable with CPTR. It is ! `INTENT(OUT)'. SHAPE (Optional) Rank-one array of type `INTEGER' ! with `INTENT(IN)'. It shall be present if and ! only if FPTR is an array. The size must be ! equal to the rank of FPTR. _Example_: program main *************** _See also_: *** 3882,3908 **** *note C_LOC::, *note C_F_PROCPOINTER::  ! File: gfortran.info, Node: C_LOC, Next: CEILING, Prev: C_FUNLOC, Up: Intrinsic Procedures ! 6.36 `C_LOC' -- Obtain the C address of an object ================================================= _Description_: ! `C_LOC(x)' determines the C address of the argument. _Standard_: ! F2003 and later _Class_: Inquiry function _Syntax_: ! `RESULT = C_LOC(x)' _Arguments_: X Associated scalar pointer or interoperable ! scalar or allocated allocatable ! variable with `TARGET' attribute. _Return value_: The return value is of type `C_PTR' and contains the C address of --- 4296,4322 ---- *note C_LOC::, *note C_F_PROCPOINTER::  ! File: gfortran.info, Node: C_LOC, Next: C_SIZEOF, Prev: C_FUNLOC, Up: Intrinsic Procedures ! 7.36 `C_LOC' -- Obtain the C address of an object ================================================= _Description_: ! `C_LOC(X)' determines the C address of the argument. _Standard_: ! Fortran 2003 and later _Class_: Inquiry function _Syntax_: ! `RESULT = C_LOC(X)' _Arguments_: X Associated scalar pointer or interoperable ! scalar or allocated allocatable variable with ! `TARGET' attribute. _Return value_: The return value is of type `C_PTR' and contains the C address of *************** _See also_: *** 3923,3953 **** C_F_PROCPOINTER::  ! File: gfortran.info, Node: CEILING, Next: CHAR, Prev: C_LOC, Up: Intrinsic Procedures ! 6.37 `CEILING' -- Integer ceiling function ========================================== _Description_: ! `CEILING(X)' returns the least integer greater than or equal to X. _Standard_: ! F95 and later _Class_: Elemental function _Syntax_: ! `RESULT = CEILING(X [, KIND])' _Arguments_: ! X The type shall be `REAL(*)'. ! KIND (Optional) An `INTEGER(*)' initialization ! expression indicating the kind ! parameter of the result. _Return value_: ! The return value is of type `INTEGER(KIND)' _Example_: program test_ceiling --- 4337,4412 ---- C_F_PROCPOINTER::  ! File: gfortran.info, Node: C_SIZEOF, Next: CEILING, Prev: C_LOC, Up: Intrinsic Procedures ! 7.37 `C_SIZEOF' -- Size in bytes of an expression ! ================================================= ! ! _Description_: ! `C_SIZEOF(X)' calculates the number of bytes of storage the ! expression `X' occupies. ! ! _Standard_: ! Fortran 2008 ! ! _Class_: ! Intrinsic function ! ! _Syntax_: ! `N = C_SIZEOF(X)' ! ! _Arguments_: ! X The argument shall be of any type, rank or ! shape. ! ! _Return value_: ! The return value is of type integer and of the system-dependent ! kind C_SIZE_T (from the ISO_C_BINDING module). Its value is the ! number of bytes occupied by the argument. If the argument has the ! `POINTER' attribute, the number of bytes of the storage area ! pointed to is returned. If the argument is of a derived type with ! `POINTER' or `ALLOCATABLE' components, the return value doesn't ! account for the sizes of the data pointed to by these components. ! ! _Example_: ! use iso_c_binding ! integer(c_int) :: i ! real(c_float) :: r, s(5) ! print *, (c_sizeof(s)/c_sizeof(r) == 5) ! end ! The example will print `.TRUE.' unless you are using a platform ! where default `REAL' variables are unusually padded. ! ! _See also_: ! *note SIZEOF:: ! !  ! File: gfortran.info, Node: CEILING, Next: CHAR, Prev: C_SIZEOF, Up: Intrinsic Procedures ! ! 7.38 `CEILING' -- Integer ceiling function ========================================== _Description_: ! `CEILING(A)' returns the least integer greater than or equal to A. _Standard_: ! Fortran 95 and later _Class_: Elemental function _Syntax_: ! `RESULT = CEILING(A [, KIND])' _Arguments_: ! A The type shall be `REAL'. ! KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: ! The return value is of type `INTEGER(KIND)' if KIND is present and ! a default-kind `INTEGER' otherwise. _Example_: program test_ceiling *************** _See also_: *** 3964,3970 ****  File: gfortran.info, Node: CHAR, Next: CHDIR, Prev: CEILING, Up: Intrinsic Procedures ! 6.38 `CHAR' -- Character conversion function ============================================ _Description_: --- 4423,4429 ----  File: gfortran.info, Node: CHAR, Next: CHDIR, Prev: CEILING, Up: Intrinsic Procedures ! 7.39 `CHAR' -- Character conversion function ============================================ _Description_: *************** _Description_: *** 3972,3978 **** integer I. _Standard_: ! F77 and later _Class_: Elemental function --- 4431,4437 ---- integer I. _Standard_: ! Fortran 77 and later _Class_: Elemental function *************** _Syntax_: *** 3981,3990 **** `RESULT = CHAR(I [, KIND])' _Arguments_: ! I The type shall be `INTEGER(*)'. ! KIND (Optional) An `INTEGER(*)' initialization ! expression indicating the kind ! parameter of the result. _Return value_: The return value is of type `CHARACTER(1)' --- 4440,4449 ---- `RESULT = CHAR(I [, KIND])' _Arguments_: ! I The type shall be `INTEGER'. ! KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: The return value is of type `CHARACTER(1)' *************** _See also_: *** 4008,4014 ****  File: gfortran.info, Node: CHDIR, Next: CHMOD, Prev: CHAR, Up: Intrinsic Procedures ! 6.39 `CHDIR' -- Change working directory ======================================== _Description_: --- 4467,4473 ----  File: gfortran.info, Node: CHDIR, Next: CHMOD, Prev: CHAR, Up: Intrinsic Procedures ! 7.40 `CHDIR' -- Change working directory ======================================== _Description_: *************** _Syntax_: *** 4028,4040 **** `STATUS = CHDIR(NAME)' _Arguments_: ! NAME The type shall be `CHARACTER(*)' and shall ! specify a valid path within ! the file system. STATUS (Optional) `INTEGER' status flag of the default ! kind. Returns 0 on ! success, and a system specific ! and nonzero error code otherwise. _Example_: PROGRAM test_chdir --- 4487,4498 ---- `STATUS = CHDIR(NAME)' _Arguments_: ! NAME The type shall be `CHARACTER' of default kind ! and shall specify a valid path within the file ! system. STATUS (Optional) `INTEGER' status flag of the default ! kind. Returns 0 on success, and a system ! specific and nonzero error code otherwise. _Example_: PROGRAM test_chdir *************** _See also_: *** 4052,4058 ****  File: gfortran.info, Node: CHMOD, Next: CMPLX, Prev: CHDIR, Up: Intrinsic Procedures ! 6.40 `CHMOD' -- Change access permissions of files ================================================== _Description_: --- 4510,4516 ----  File: gfortran.info, Node: CHMOD, Next: CMPLX, Prev: CHDIR, Up: Intrinsic Procedures ! 7.41 `CHMOD' -- Change access permissions of files ================================================== _Description_: *************** _Syntax_: *** 4073,4086 **** `STATUS = CHMOD(NAME, MODE)' _Arguments_: ! NAME Scalar `CHARACTER' with the file name. ! Trailing blanks are ignored unless the ! character `achar(0)' is present, then all characters up to and excluding `achar(0)' are used as the file name. ! MODE Scalar `CHARACTER' giving the file permission. ! MODE uses the same syntax as the MODE argument ! of `/bin/chmod'. STATUS (optional) scalar `INTEGER', which is `0' on success and nonzero otherwise. --- 4531,4544 ---- `STATUS = CHMOD(NAME, MODE)' _Arguments_: ! NAME Scalar `CHARACTER' of default kind with the ! file name. Trailing blanks are ignored unless ! the character `achar(0)' is present, then all characters up to and excluding `achar(0)' are used as the file name. ! MODE Scalar `CHARACTER' of default kind giving the ! file permission. MODE uses the same syntax as ! the MODE argument of `/bin/chmod'. STATUS (optional) scalar `INTEGER', which is `0' on success and nonzero otherwise. *************** _Example_: *** 4108,4114 ****  File: gfortran.info, Node: CMPLX, Next: COMMAND_ARGUMENT_COUNT, Prev: CHMOD, Up: Intrinsic Procedures ! 6.41 `CMPLX' -- Complex conversion function =========================================== _Description_: --- 4566,4572 ----  File: gfortran.info, Node: CMPLX, Next: COMMAND_ARGUMENT_COUNT, Prev: CHMOD, Up: Intrinsic Procedures ! 7.42 `CMPLX' -- Complex conversion function =========================================== _Description_: *************** _Description_: *** 4119,4125 **** not be present. _Standard_: ! F77 and later _Class_: Elemental function --- 4577,4583 ---- not be present. _Standard_: ! Fortran 77 and later _Class_: Elemental function *************** _Syntax_: *** 4128,4141 **** `RESULT = CMPLX(X [, Y [, KIND]])' _Arguments_: ! X The type may be `INTEGER(*)', `REAL(*)', ! or `COMPLEX(*)'. Y (Optional; only allowed if X is not ! `COMPLEX(*)'.) May be `INTEGER(*)' ! or `REAL(*)'. ! KIND (Optional) An `INTEGER(*)' initialization ! expression indicating the kind ! parameter of the result. _Return value_: The return value is of `COMPLEX' type, with a kind equal to KIND --- 4586,4598 ---- `RESULT = CMPLX(X [, Y [, KIND]])' _Arguments_: ! X The type may be `INTEGER', `REAL', or ! `COMPLEX'. Y (Optional; only allowed if X is not ! `COMPLEX'.) May be `INTEGER' or `REAL'. ! KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: The return value is of `COMPLEX' type, with a kind equal to KIND *************** _See also_: *** 4157,4163 ****  File: gfortran.info, Node: COMMAND_ARGUMENT_COUNT, Next: COMPLEX, Prev: CMPLX, Up: Intrinsic Procedures ! 6.42 `COMMAND_ARGUMENT_COUNT' -- Get number of command line arguments ===================================================================== _Description_: --- 4614,4620 ----  File: gfortran.info, Node: COMMAND_ARGUMENT_COUNT, Next: COMPLEX, Prev: CMPLX, Up: Intrinsic Procedures ! 7.43 `COMMAND_ARGUMENT_COUNT' -- Get number of command line arguments ===================================================================== _Description_: *************** _Description_: *** 4165,4171 **** on the command line when the containing program was invoked. _Standard_: ! F2003 _Class_: Inquiry function --- 4622,4628 ---- on the command line when the containing program was invoked. _Standard_: ! Fortran 2003 and later _Class_: Inquiry function *************** _See also_: *** 4192,4198 ****  File: gfortran.info, Node: COMPLEX, Next: CONJG, Prev: COMMAND_ARGUMENT_COUNT, Up: Intrinsic Procedures ! 6.43 `COMPLEX' -- Complex conversion function ============================================= _Description_: --- 4649,4655 ----  File: gfortran.info, Node: COMPLEX, Next: CONJG, Prev: COMMAND_ARGUMENT_COUNT, Up: Intrinsic Procedures ! 7.44 `COMPLEX' -- Complex conversion function ============================================= _Description_: *************** _Syntax_: *** 4209,4216 **** `RESULT = COMPLEX(X, Y)' _Arguments_: ! X The type may be `INTEGER(*)' or `REAL(*)'. ! Y The type may be `INTEGER(*)' or `REAL(*)'. _Return value_: If X and Y are both of `INTEGER' type, then the return value is of --- 4666,4673 ---- `RESULT = COMPLEX(X, Y)' _Arguments_: ! X The type may be `INTEGER' or `REAL'. ! Y The type may be `INTEGER' or `REAL'. _Return value_: If X and Y are both of `INTEGER' type, then the return value is of *************** _See also_: *** 4234,4240 ****  File: gfortran.info, Node: CONJG, Next: COS, Prev: COMPLEX, Up: Intrinsic Procedures ! 6.44 `CONJG' -- Complex conjugate function ========================================== _Description_: --- 4691,4697 ----  File: gfortran.info, Node: CONJG, Next: COS, Prev: COMPLEX, Up: Intrinsic Procedures ! 7.45 `CONJG' -- Complex conjugate function ========================================== _Description_: *************** _Description_: *** 4242,4248 **** result is `(x, -y)' _Standard_: ! F77 and later, has overloads that are GNU extensions _Class_: Elemental function --- 4699,4705 ---- result is `(x, -y)' _Standard_: ! Fortran 77 and later, has overloads that are GNU extensions _Class_: Elemental function *************** _Syntax_: *** 4251,4260 **** `Z = CONJG(Z)' _Arguments_: ! Z The type shall be `COMPLEX(*)'. _Return value_: ! The return value is of type `COMPLEX(*)'. _Example_: program test_conjg --- 4708,4717 ---- `Z = CONJG(Z)' _Arguments_: ! Z The type shall be `COMPLEX'. _Return value_: ! The return value is of type `COMPLEX'. _Example_: program test_conjg *************** _Specific names_: *** 4274,4287 ****  File: gfortran.info, Node: COS, Next: COSH, Prev: CONJG, Up: Intrinsic Procedures ! 6.45 `COS' -- Cosine function ============================= _Description_: `COS(X)' computes the cosine of X. _Standard_: ! F77 and later, has overloads that are GNU extensions _Class_: Elemental function --- 4731,4744 ----  File: gfortran.info, Node: COS, Next: COSH, Prev: CONJG, Up: Intrinsic Procedures ! 7.46 `COS' -- Cosine function ============================= _Description_: `COS(X)' computes the cosine of X. _Standard_: ! Fortran 77 and later, has overloads that are GNU extensions _Class_: Elemental function *************** _Syntax_: *** 4290,4299 **** `RESULT = COS(X)' _Arguments_: ! X The type shall be `REAL(*)' or `COMPLEX(*)'. _Return value_: ! The return value is of type `REAL(*)' and it lies in the range -1 \leq \cos (x) \leq 1. The kind type parameter is the same as X. _Example_: --- 4747,4756 ---- `RESULT = COS(X)' _Arguments_: ! X The type shall be `REAL' or `COMPLEX'. _Return value_: ! The return value is of type `REAL' and it lies in the range -1 \leq \cos (x) \leq 1. The kind type parameter is the same as X. _Example_: *************** _Example_: *** 4304,4312 **** _Specific names_: Name Argument Return type Standard ! `DCOS(X)' `REAL(8) X' `REAL(8)' F77 and later ! `CCOS(X)' `COMPLEX(4) `COMPLEX(4)' F77 and later ! X' `ZCOS(X)' `COMPLEX(8) `COMPLEX(8)' GNU extension X' `CDCOS(X)' `COMPLEX(8) `COMPLEX(8)' GNU extension --- 4761,4770 ---- _Specific names_: Name Argument Return type Standard ! `DCOS(X)' `REAL(8) X' `REAL(8)' Fortran 77 and ! later ! `CCOS(X)' `COMPLEX(4) `COMPLEX(4)' Fortran 77 and ! X' later `ZCOS(X)' `COMPLEX(8) `COMPLEX(8)' GNU extension X' `CDCOS(X)' `COMPLEX(8) `COMPLEX(8)' GNU extension *************** _See also_: *** 4319,4332 ****  File: gfortran.info, Node: COSH, Next: COUNT, Prev: COS, Up: Intrinsic Procedures ! 6.46 `COSH' -- Hyperbolic cosine function ========================================= _Description_: `COSH(X)' computes the hyperbolic cosine of X. _Standard_: ! F77 and later _Class_: Elemental function --- 4777,4790 ----  File: gfortran.info, Node: COSH, Next: COUNT, Prev: COS, Up: Intrinsic Procedures ! 7.47 `COSH' -- Hyperbolic cosine function ========================================= _Description_: `COSH(X)' computes the hyperbolic cosine of X. _Standard_: ! Fortran 77 and later _Class_: Elemental function *************** _Syntax_: *** 4335,4345 **** `X = COSH(X)' _Arguments_: ! X The type shall be `REAL(*)'. _Return value_: ! The return value is of type `REAL(*)' and it is positive ( \cosh ! (x) \geq 0 . _Example_: program test_cosh --- 4793,4804 ---- `X = COSH(X)' _Arguments_: ! X The type shall be `REAL'. _Return value_: ! The return value is of type `REAL' and it is positive ( \cosh (x) ! \geq 0 ). For a `REAL' argument X, \cosh (x) \geq 1 . The ! return value is of the same kind as X. _Example_: program test_cosh *************** _Example_: *** 4349,4355 **** _Specific names_: Name Argument Return type Standard ! `DCOSH(X)' `REAL(8) X' `REAL(8)' F77 and later _See also_: Inverse function: *note ACOSH:: --- 4808,4815 ---- _Specific names_: Name Argument Return type Standard ! `DCOSH(X)' `REAL(8) X' `REAL(8)' Fortran 77 and ! later _See also_: Inverse function: *note ACOSH:: *************** _See also_: *** 4358,4374 ****  File: gfortran.info, Node: COUNT, Next: CPU_TIME, Prev: COSH, Up: Intrinsic Procedures ! 6.47 `COUNT' -- Count function ============================== _Description_: `COUNT(MASK [, DIM [, KIND]])' counts the number of `.TRUE.' elements of MASK along the dimension of DIM. If DIM is omitted it ! is taken to be `1'. DIM is a scaler of type `INTEGER' in the range of 1 /leq DIM /leq n) where n is the rank of MASK. _Standard_: ! F95 and later _Class_: Transformational function --- 4818,4834 ----  File: gfortran.info, Node: COUNT, Next: CPU_TIME, Prev: COSH, Up: Intrinsic Procedures ! 7.48 `COUNT' -- Count function ============================== _Description_: `COUNT(MASK [, DIM [, KIND]])' counts the number of `.TRUE.' elements of MASK along the dimension of DIM. If DIM is omitted it ! is taken to be `1'. DIM is a scalar of type `INTEGER' in the range of 1 /leq DIM /leq n) where n is the rank of MASK. _Standard_: ! Fortran 95 and later, with KIND argument Fortran 2003 and later _Class_: Transformational function *************** _Arguments_: *** 4380,4387 **** MASK The type shall be `LOGICAL'. DIM (Optional) The type shall be `INTEGER'. KIND (Optional) An `INTEGER' initialization ! expression indicating the kind ! parameter of the result. _Return value_: The return value is of type `INTEGER' and of kind KIND. If KIND is --- 4840,4847 ---- MASK The type shall be `LOGICAL'. DIM (Optional) The type shall be `INTEGER'. KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: The return value is of type `INTEGER' and of kind KIND. If KIND is *************** _Example_: *** 4414,4424 ****  File: gfortran.info, Node: CPU_TIME, Next: CSHIFT, Prev: COUNT, Up: Intrinsic Procedures ! 6.48 `CPU_TIME' -- CPU elapsed time in seconds ============================================== _Description_: ! Returns a `REAL(*)' value representing the elapsed CPU time in seconds. This is useful for testing segments of code to determine execution time. --- 4874,4884 ----  File: gfortran.info, Node: CPU_TIME, Next: CSHIFT, Prev: COUNT, Up: Intrinsic Procedures ! 7.49 `CPU_TIME' -- CPU elapsed time in seconds ============================================== _Description_: ! Returns a `REAL' value representing the elapsed CPU time in seconds. This is useful for testing segments of code to determine execution time. *************** _Description_: *** 4432,4438 **** subroutine, as shown in the example below, should be used. _Standard_: ! F95 and later _Class_: Subroutine --- 4892,4898 ---- subroutine, as shown in the example below, should be used. _Standard_: ! Fortran 95 and later _Class_: Subroutine *************** _Syntax_: *** 4441,4447 **** `CALL CPU_TIME(TIME)' _Arguments_: ! TIME The type shall be `REAL(*)' with `INTENT(OUT)'. _Return value_: None --- 4901,4907 ---- `CALL CPU_TIME(TIME)' _Arguments_: ! TIME The type shall be `REAL' with `INTENT(OUT)'. _Return value_: None *************** _See also_: *** 4461,4473 ****  File: gfortran.info, Node: CSHIFT, Next: CTIME, Prev: CPU_TIME, Up: Intrinsic Procedures ! 6.49 `CSHIFT' -- Circular shift elements of an array ==================================================== _Description_: `CSHIFT(ARRAY, SHIFT [, DIM])' performs a circular shift on elements of ARRAY along the dimension of DIM. If DIM is omitted ! it is taken to be `1'. DIM is a scaler of type `INTEGER' in the range of 1 /leq DIM /leq n) where n is the rank of ARRAY. If the rank of ARRAY is one, then all elements of ARRAY are shifted by SHIFT places. If rank is greater than one, then all complete rank --- 4921,4933 ----  File: gfortran.info, Node: CSHIFT, Next: CTIME, Prev: CPU_TIME, Up: Intrinsic Procedures ! 7.50 `CSHIFT' -- Circular shift elements of an array ==================================================== _Description_: `CSHIFT(ARRAY, SHIFT [, DIM])' performs a circular shift on elements of ARRAY along the dimension of DIM. If DIM is omitted ! it is taken to be `1'. DIM is a scalar of type `INTEGER' in the range of 1 /leq DIM /leq n) where n is the rank of ARRAY. If the rank of ARRAY is one, then all elements of ARRAY are shifted by SHIFT places. If rank is greater than one, then all complete rank *************** _Description_: *** 4476,4482 **** back in the other end. _Standard_: ! F95 and later _Class_: Transformational function --- 4936,4942 ---- back in the other end. _Standard_: ! Fortran 95 and later _Class_: Transformational function *************** _Example_: *** 4509,4515 ****  File: gfortran.info, Node: CTIME, Next: DATE_AND_TIME, Prev: CSHIFT, Up: Intrinsic Procedures ! 6.50 `CTIME' -- Convert a time into a string ============================================ _Description_: --- 4969,4975 ----  File: gfortran.info, Node: CTIME, Next: DATE_AND_TIME, Prev: CSHIFT, Up: Intrinsic Procedures ! 7.51 `CTIME' -- Convert a time into a string ============================================ _Description_: *************** _Syntax_: *** 4531,4537 **** _Arguments_: TIME The type shall be of type `INTEGER(KIND=8)'. ! RESULT The type shall be of type `CHARACTER'. _Return value_: The converted date and time as a string. --- 4991,4998 ---- _Arguments_: TIME The type shall be of type `INTEGER(KIND=8)'. ! RESULT The type shall be of type `CHARACTER' and of ! default kind. _Return value_: The converted date and time as a string. *************** _See Also_: *** 4554,4560 ****  File: gfortran.info, Node: DATE_AND_TIME, Next: DBLE, Prev: CTIME, Up: Intrinsic Procedures ! 6.51 `DATE_AND_TIME' -- Date and time subroutine ================================================ _Description_: --- 5015,5021 ----  File: gfortran.info, Node: DATE_AND_TIME, Next: DBLE, Prev: CTIME, Up: Intrinsic Procedures ! 7.52 `DATE_AND_TIME' -- Date and time subroutine ================================================ _Description_: *************** _Description_: *** 4579,4585 **** second _Standard_: ! F95 and later _Class_: Subroutine --- 5040,5046 ---- second _Standard_: ! Fortran 95 and later _Class_: Subroutine *************** _Syntax_: *** 4588,4599 **** `CALL DATE_AND_TIME([DATE, TIME, ZONE, VALUES])' _Arguments_: ! DATE (Optional) The type shall be `CHARACTER(8)' or ! larger. ! TIME (Optional) The type shall be `CHARACTER(10)' ! or larger. ! ZONE (Optional) The type shall be `CHARACTER(5)' or ! larger. VALUES (Optional) The type shall be `INTEGER(8)'. _Return value_: --- 5049,5061 ---- `CALL DATE_AND_TIME([DATE, TIME, ZONE, VALUES])' _Arguments_: ! DATE (Optional) The type shall be `CHARACTER(LEN=8)' ! or larger, and of default kind. ! TIME (Optional) The type shall be ! `CHARACTER(LEN=10)' or larger, and of default ! kind. ! ZONE (Optional) The type shall be `CHARACTER(LEN=5)' ! or larger, and of default kind. VALUES (Optional) The type shall be `INTEGER(8)'. _Return value_: *************** _See also_: *** 4620,4643 ****  File: gfortran.info, Node: DBLE, Next: DCMPLX, Prev: DATE_AND_TIME, Up: Intrinsic Procedures ! 6.52 `DBLE' -- Double conversion function ========================================= _Description_: ! `DBLE(X)' Converts X to double precision real type. _Standard_: ! F77 and later _Class_: Elemental function _Syntax_: ! `RESULT = DBLE(X)' _Arguments_: ! X The type shall be `INTEGER(*)', `REAL(*)', ! or `COMPLEX(*)'. _Return value_: The return value is of type double precision real. --- 5082,5105 ----  File: gfortran.info, Node: DBLE, Next: DCMPLX, Prev: DATE_AND_TIME, Up: Intrinsic Procedures ! 7.53 `DBLE' -- Double conversion function ========================================= _Description_: ! `DBLE(A)' Converts A to double precision real type. _Standard_: ! Fortran 77 and later _Class_: Elemental function _Syntax_: ! `RESULT = DBLE(A)' _Arguments_: ! A The type shall be `INTEGER', `REAL', or ! `COMPLEX'. _Return value_: The return value is of type double precision real. *************** _See also_: *** 4656,4662 ****  File: gfortran.info, Node: DCMPLX, Next: DFLOAT, Prev: DBLE, Up: Intrinsic Procedures ! 6.53 `DCMPLX' -- Double complex conversion function =================================================== _Description_: --- 5118,5124 ----  File: gfortran.info, Node: DCMPLX, Next: DFLOAT, Prev: DBLE, Up: Intrinsic Procedures ! 7.54 `DCMPLX' -- Double complex conversion function =================================================== _Description_: *************** _Syntax_: *** 4676,4685 **** `RESULT = DCMPLX(X [, Y])' _Arguments_: ! X The type may be `INTEGER(*)', `REAL(*)', ! or `COMPLEX(*)'. ! Y (Optional if X is not `COMPLEX(*)'.) May be ! `INTEGER(*)' or `REAL(*)'. _Return value_: The return value is of type `COMPLEX(8)' --- 5138,5147 ---- `RESULT = DCMPLX(X [, Y])' _Arguments_: ! X The type may be `INTEGER', `REAL', or ! `COMPLEX'. ! Y (Optional if X is not `COMPLEX'.) May be ! `INTEGER' or `REAL'. _Return value_: The return value is of type `COMPLEX(8)' *************** _Example_: *** 4699,4709 ****  File: gfortran.info, Node: DFLOAT, Next: DIGITS, Prev: DCMPLX, Up: Intrinsic Procedures ! 6.54 `DFLOAT' -- Double conversion function =========================================== _Description_: ! `DFLOAT(X)' Converts X to double precision real type. _Standard_: GNU extension --- 5161,5171 ----  File: gfortran.info, Node: DFLOAT, Next: DIGITS, Prev: DCMPLX, Up: Intrinsic Procedures ! 7.55 `DFLOAT' -- Double conversion function =========================================== _Description_: ! `DFLOAT(A)' Converts A to double precision real type. _Standard_: GNU extension *************** _Class_: *** 4712,4721 **** Elemental function _Syntax_: ! `RESULT = DFLOAT(X)' _Arguments_: ! X The type shall be `INTEGER(*)'. _Return value_: The return value is of type double precision real. --- 5174,5183 ---- Elemental function _Syntax_: ! `RESULT = DFLOAT(A)' _Arguments_: ! A The type shall be `INTEGER'. _Return value_: The return value is of type double precision real. *************** _See also_: *** 4732,4748 ****  File: gfortran.info, Node: DIGITS, Next: DIM, Prev: DFLOAT, Up: Intrinsic Procedures ! 6.55 `DIGITS' -- Significant digits function ! ============================================ _Description_: ! `DIGITS(X)' returns the number of significant digits of the internal model representation of X. For example, on a system using a 32-bit floating point representation, a default real number would likely return 24. _Standard_: ! F95 and later _Class_: Inquiry function --- 5194,5210 ----  File: gfortran.info, Node: DIGITS, Next: DIM, Prev: DFLOAT, Up: Intrinsic Procedures ! 7.56 `DIGITS' -- Significant binary digits function ! =================================================== _Description_: ! `DIGITS(X)' returns the number of significant binary digits of the internal model representation of X. For example, on a system using a 32-bit floating point representation, a default real number would likely return 24. _Standard_: ! Fortran 95 and later _Class_: Inquiry function *************** _Syntax_: *** 4751,4757 **** `RESULT = DIGITS(X)' _Arguments_: ! X The type may be `INTEGER(*)' or `REAL(*)'. _Return value_: The return value is of type `INTEGER'. --- 5213,5219 ---- `RESULT = DIGITS(X)' _Arguments_: ! X The type may be `INTEGER' or `REAL'. _Return value_: The return value is of type `INTEGER'. *************** _Example_: *** 4769,4775 ****  File: gfortran.info, Node: DIM, Next: DOT_PRODUCT, Prev: DIGITS, Up: Intrinsic Procedures ! 6.56 `DIM' -- Positive difference ================================= _Description_: --- 5231,5237 ----  File: gfortran.info, Node: DIM, Next: DOT_PRODUCT, Prev: DIGITS, Up: Intrinsic Procedures ! 7.57 `DIM' -- Positive difference ================================= _Description_: *************** _Description_: *** 4777,4783 **** otherwise returns zero. _Standard_: ! F77 and later _Class_: Elemental function --- 5239,5245 ---- otherwise returns zero. _Standard_: ! Fortran 77 and later _Class_: Elemental function *************** _Syntax_: *** 4786,4796 **** `RESULT = DIM(X, Y)' _Arguments_: ! X The type shall be `INTEGER(*)' or `REAL(*)' Y The type shall be the same type and kind as X. _Return value_: ! The return value is of type `INTEGER(*)' or `REAL(*)'. _Example_: program test_dim --- 5248,5258 ---- `RESULT = DIM(X, Y)' _Arguments_: ! X The type shall be `INTEGER' or `REAL' Y The type shall be the same type and kind as X. _Return value_: ! The return value is of type `INTEGER' or `REAL'. _Example_: program test_dim *************** _Example_: *** 4804,4845 **** _Specific names_: Name Argument Return type Standard ! `IDIM(X,Y)' `INTEGER(4) `INTEGER(4)' F77 and later ! X,Y' ! `DDIM(X,Y)' `REAL(8) `REAL(8)' F77 and later ! X,Y'  File: gfortran.info, Node: DOT_PRODUCT, Next: DPROD, Prev: DIM, Up: Intrinsic Procedures ! 6.57 `DOT_PRODUCT' -- Dot product function ========================================== _Description_: ! `DOT_PRODUCT(X,Y)' computes the dot product multiplication of two ! vectors X and Y. The two vectors may be either numeric or logical ! and must be arrays of rank one and of equal size. If the vectors ! are `INTEGER(*)' or `REAL(*)', the result is `SUM(X*Y)'. If the ! vectors are `COMPLEX(*)', the result is `SUM(CONJG(X)*Y)'. If the ! vectors are `LOGICAL', the result is `ANY(X.AND.Y)'. _Standard_: ! F95 and later _Class_: Transformational function _Syntax_: ! `RESULT = DOT_PRODUCT(X, Y)' _Arguments_: ! X The type shall be numeric or `LOGICAL', rank 1. ! Y The type shall be numeric or `LOGICAL', rank 1. _Return value_: ! If the arguments are numeric, the return value is a scaler of ! numeric type, `INTEGER(*)', `REAL(*)', or `COMPLEX(*)'. If the ! arguments are `LOGICAL', the return value is `.TRUE.' or `.FALSE.'. _Example_: program test_dot_prod --- 5266,5312 ---- _Specific names_: Name Argument Return type Standard ! `IDIM(X,Y)' `INTEGER(4) `INTEGER(4)' Fortran 77 and ! X,Y' later ! `DDIM(X,Y)' `REAL(8) `REAL(8)' Fortran 77 and ! X,Y' later  File: gfortran.info, Node: DOT_PRODUCT, Next: DPROD, Prev: DIM, Up: Intrinsic Procedures ! 7.58 `DOT_PRODUCT' -- Dot product function ========================================== _Description_: ! `DOT_PRODUCT(VECTOR_A, VECTOR_B)' computes the dot product ! multiplication of two vectors VECTOR_A and VECTOR_B. The two ! vectors may be either numeric or logical and must be arrays of ! rank one and of equal size. If the vectors are `INTEGER' or ! `REAL', the result is `SUM(VECTOR_A*VECTOR_B)'. If the vectors are ! `COMPLEX', the result is `SUM(CONJG(VECTOR_A)*VECTOR_B)'. If the ! vectors are `LOGICAL', the result is `ANY(VECTOR_A .AND. ! VECTOR_B)'. _Standard_: ! Fortran 95 and later _Class_: Transformational function _Syntax_: ! `RESULT = DOT_PRODUCT(VECTOR_A, VECTOR_B)' _Arguments_: ! VECTOR_A The type shall be numeric or `LOGICAL', rank 1. ! VECTOR_B The type shall be numeric if VECTOR_A is of ! numeric type or `LOGICAL' if VECTOR_A is of ! type `LOGICAL'. VECTOR_B shall be a rank-one ! array. _Return value_: ! If the arguments are numeric, the return value is a scalar of ! numeric type, `INTEGER', `REAL', or `COMPLEX'. If the arguments ! are `LOGICAL', the return value is `.TRUE.' or `.FALSE.'. _Example_: program test_dot_prod *************** _Example_: *** 4856,4869 ****  File: gfortran.info, Node: DPROD, Next: DREAL, Prev: DOT_PRODUCT, Up: Intrinsic Procedures ! 6.58 `DPROD' -- Double product function ======================================= _Description_: `DPROD(X,Y)' returns the product `X*Y'. _Standard_: ! F77 and later _Class_: Elemental function --- 5323,5336 ----  File: gfortran.info, Node: DPROD, Next: DREAL, Prev: DOT_PRODUCT, Up: Intrinsic Procedures ! 7.59 `DPROD' -- Double product function ======================================= _Description_: `DPROD(X,Y)' returns the product `X*Y'. _Standard_: ! Fortran 77 and later _Class_: Elemental function *************** _Example_: *** 4890,4896 ****  File: gfortran.info, Node: DREAL, Next: DTIME, Prev: DPROD, Up: Intrinsic Procedures ! 6.59 `DREAL' -- Double real part function ========================================= _Description_: --- 5357,5363 ----  File: gfortran.info, Node: DREAL, Next: DTIME, Prev: DPROD, Up: Intrinsic Procedures ! 7.60 `DREAL' -- Double real part function ========================================= _Description_: *************** _Class_: *** 4903,4912 **** Elemental function _Syntax_: ! `RESULT = DREAL(Z)' _Arguments_: ! Z The type shall be `COMPLEX(8)'. _Return value_: The return value is of type `REAL(8)'. --- 5370,5379 ---- Elemental function _Syntax_: ! `RESULT = DREAL(A)' _Arguments_: ! A The type shall be `COMPLEX(8)'. _Return value_: The return value is of type `REAL(8)'. *************** _See also_: *** 4924,4930 ****  File: gfortran.info, Node: DTIME, Next: EOSHIFT, Prev: DREAL, Up: Intrinsic Procedures ! 6.60 `DTIME' -- Execution time subroutine (or function) ======================================================= _Description_: --- 5391,5397 ----  File: gfortran.info, Node: DTIME, Next: EOSHIFT, Prev: DREAL, Up: Intrinsic Procedures ! 7.61 `DTIME' -- Execution time subroutine (or function) ======================================================= _Description_: *************** _Description_: *** 4945,4951 **** program. Please note, that this implementation is thread safe if used ! within OpenMP directives, i. e. its state will be consistent while called from multiple threads. However, if `DTIME' is called from multiple threads, the result is still the time since the last invocation. This may not give the intended results. If possible, --- 5412,5418 ---- program. Please note, that this implementation is thread safe if used ! within OpenMP directives, i.e., its state will be consistent while called from multiple threads. However, if `DTIME' is called from multiple threads, the result is still the time since the last invocation. This may not give the intended results. If possible, *************** _See also_: *** 5004,5016 ****  File: gfortran.info, Node: EOSHIFT, Next: EPSILON, Prev: DTIME, Up: Intrinsic Procedures ! 6.61 `EOSHIFT' -- End-off shift elements of an array ==================================================== _Description_: ! `EOSHIFT(ARRAY, SHIFT[,BOUNDARY, DIM])' performs an end-off shift on elements of ARRAY along the dimension of DIM. If DIM is ! omitted it is taken to be `1'. DIM is a scaler of type `INTEGER' in the range of 1 /leq DIM /leq n) where n is the rank of ARRAY. If the rank of ARRAY is one, then all elements of ARRAY are shifted by SHIFT places. If rank is greater than one, then all --- 5471,5483 ----  File: gfortran.info, Node: EOSHIFT, Next: EPSILON, Prev: DTIME, Up: Intrinsic Procedures ! 7.62 `EOSHIFT' -- End-off shift elements of an array ==================================================== _Description_: ! `EOSHIFT(ARRAY, SHIFT[, BOUNDARY, DIM])' performs an end-off shift on elements of ARRAY along the dimension of DIM. If DIM is ! omitted it is taken to be `1'. DIM is a scalar of type `INTEGER' in the range of 1 /leq DIM /leq n) where n is the rank of ARRAY. If the rank of ARRAY is one, then all elements of ARRAY are shifted by SHIFT places. If rank is greater than one, then all *************** _Description_: *** 5028,5034 **** Character(LEN)LEN blanks. _Standard_: ! F95 and later _Class_: Transformational function --- 5495,5501 ---- Character(LEN)LEN blanks. _Standard_: ! Fortran 95 and later _Class_: Transformational function *************** _Syntax_: *** 5037,5043 **** `RESULT = EOSHIFT(ARRAY, SHIFT [, BOUNDARY, DIM])' _Arguments_: ! ARRAY May be any type, not scaler. SHIFT The type shall be `INTEGER'. BOUNDARY Same type as ARRAY. DIM The type shall be `INTEGER'. --- 5504,5510 ---- `RESULT = EOSHIFT(ARRAY, SHIFT [, BOUNDARY, DIM])' _Arguments_: ! ARRAY May be any type, not scalar. SHIFT The type shall be `INTEGER'. BOUNDARY Same type as ARRAY. DIM The type shall be `INTEGER'. *************** _Example_: *** 5062,5075 ****  File: gfortran.info, Node: EPSILON, Next: ERF, Prev: EOSHIFT, Up: Intrinsic Procedures ! 6.62 `EPSILON' -- Epsilon function ================================== _Description_: ! `EPSILON(X)' returns a nearly negligible number relative to `1'. _Standard_: ! F95 and later _Class_: Inquiry function --- 5529,5543 ----  File: gfortran.info, Node: EPSILON, Next: ERF, Prev: EOSHIFT, Up: Intrinsic Procedures ! 7.63 `EPSILON' -- Epsilon function ================================== _Description_: ! `EPSILON(X)' returns the smallest number E of the same kind as X ! such that 1 + E > 1. _Standard_: ! Fortran 95 and later _Class_: Inquiry function *************** _Syntax_: *** 5078,5084 **** `RESULT = EPSILON(X)' _Arguments_: ! X The type shall be `REAL(*)'. _Return value_: The return value is of same type as the argument. --- 5546,5552 ---- `RESULT = EPSILON(X)' _Arguments_: ! X The type shall be `REAL'. _Return value_: The return value is of same type as the argument. *************** _Example_: *** 5094,5107 ****  File: gfortran.info, Node: ERF, Next: ERFC, Prev: EPSILON, Up: Intrinsic Procedures ! 6.63 `ERF' -- Error function ============================ _Description_: `ERF(X)' computes the error function of X. _Standard_: ! GNU Extension _Class_: Elemental function --- 5562,5575 ----  File: gfortran.info, Node: ERF, Next: ERFC, Prev: EPSILON, Up: Intrinsic Procedures ! 7.64 `ERF' -- Error function ============================ _Description_: `ERF(X)' computes the error function of X. _Standard_: ! Fortran 2008 and later _Class_: Elemental function *************** _Syntax_: *** 5110,5121 **** `RESULT = ERF(X)' _Arguments_: ! X The type shall be `REAL(*)', and it shall be ! scalar. _Return value_: ! The return value is a scalar of type `REAL(*)' and it is positive ! ( - 1 \leq erf (x) \leq 1 . _Example_: program test_erf --- 5578,5588 ---- `RESULT = ERF(X)' _Arguments_: ! X The type shall be `REAL'. _Return value_: ! The return value is of type `REAL', of the same kind as X and lies ! in the range -1 \leq erf (x) \leq 1 . _Example_: program test_erf *************** _Specific names_: *** 5128,5143 **** `DERF(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: ERFC, Next: ETIME, Prev: ERF, Up: Intrinsic Procedures ! 6.64 `ERFC' -- Error function ============================= _Description_: `ERFC(X)' computes the complementary error function of X. _Standard_: ! GNU extension _Class_: Elemental function --- 5595,5610 ---- `DERF(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: ERFC, Next: ERFC_SCALED, Prev: ERF, Up: Intrinsic Procedures ! 7.65 `ERFC' -- Error function ============================= _Description_: `ERFC(X)' computes the complementary error function of X. _Standard_: ! Fortran 2008 and later _Class_: Elemental function *************** _Syntax_: *** 5146,5157 **** `RESULT = ERFC(X)' _Arguments_: ! X The type shall be `REAL(*)', and it shall be ! scalar. _Return value_: ! The return value is a scalar of type `REAL(*)' and it is positive ! ( 0 \leq erfc (x) \leq 2 . _Example_: program test_erfc --- 5613,5623 ---- `RESULT = ERFC(X)' _Arguments_: ! X The type shall be `REAL'. _Return value_: ! The return value is of type `REAL' and of the same kind as X. It ! lies in the range 0 \leq erfc (x) \leq 2 . _Example_: program test_erfc *************** _Specific names_: *** 5164,5172 **** `DERFC(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: ETIME, Next: EXIT, Prev: ERFC, Up: Intrinsic Procedures ! 6.65 `ETIME' -- Execution time subroutine (or function) ======================================================= _Description_: --- 5630,5669 ---- `DERFC(X)' `REAL(8) X' `REAL(8)' GNU extension  ! File: gfortran.info, Node: ERFC_SCALED, Next: ETIME, Prev: ERFC, Up: Intrinsic Procedures ! 7.66 `ERFC_SCALED' -- Error function ! ==================================== ! ! _Description_: ! `ERFC_SCALED(X)' computes the exponentially-scaled complementary ! error function of X. ! ! _Standard_: ! Fortran 2008 and later ! ! _Class_: ! Elemental function ! ! _Syntax_: ! `RESULT = ERFC_SCALED(X)' ! ! _Arguments_: ! X The type shall be `REAL'. ! ! _Return value_: ! The return value is of type `REAL' and of the same kind as X. ! ! _Example_: ! program test_erfc_scaled ! real(8) :: x = 0.17_8 ! x = erfc_scaled(x) ! end program test_erfc_scaled ! !  ! File: gfortran.info, Node: ETIME, Next: EXIT, Prev: ERFC_SCALED, Up: Intrinsic Procedures ! ! 7.67 `ETIME' -- Execution time subroutine (or function) ======================================================= _Description_: *************** _See also_: *** 5234,5240 ****  File: gfortran.info, Node: EXIT, Next: EXP, Prev: ETIME, Up: Intrinsic Procedures ! 6.66 `EXIT' -- Exit the program with status. ============================================ _Description_: --- 5731,5737 ----  File: gfortran.info, Node: EXIT, Next: EXP, Prev: ETIME, Up: Intrinsic Procedures ! 7.68 `EXIT' -- Exit the program with status. ============================================ _Description_: *************** _See also_: *** 5270,5283 ****  File: gfortran.info, Node: EXP, Next: EXPONENT, Prev: EXIT, Up: Intrinsic Procedures ! 6.67 `EXP' -- Exponential function ================================== _Description_: `EXP(X)' computes the base e exponential of X. _Standard_: ! F77 and later, has overloads that are GNU extensions _Class_: Elemental function --- 5767,5780 ----  File: gfortran.info, Node: EXP, Next: EXPONENT, Prev: EXIT, Up: Intrinsic Procedures ! 7.69 `EXP' -- Exponential function ================================== _Description_: `EXP(X)' computes the base e exponential of X. _Standard_: ! Fortran 77 and later, has overloads that are GNU extensions _Class_: Elemental function *************** _Syntax_: *** 5286,5292 **** `RESULT = EXP(X)' _Arguments_: ! X The type shall be `REAL(*)' or `COMPLEX(*)'. _Return value_: The return value has same type and kind as X. --- 5783,5789 ---- `RESULT = EXP(X)' _Arguments_: ! X The type shall be `REAL' or `COMPLEX'. _Return value_: The return value has same type and kind as X. *************** _Example_: *** 5299,5307 **** _Specific names_: Name Argument Return type Standard ! `DEXP(X)' `REAL(8) X' `REAL(8)' F77 and later ! `CEXP(X)' `COMPLEX(4) `COMPLEX(4)' F77 and later ! X' `ZEXP(X)' `COMPLEX(8) `COMPLEX(8)' GNU extension X' `CDEXP(X)' `COMPLEX(8) `COMPLEX(8)' GNU extension --- 5796,5805 ---- _Specific names_: Name Argument Return type Standard ! `DEXP(X)' `REAL(8) X' `REAL(8)' Fortran 77 and ! later ! `CEXP(X)' `COMPLEX(4) `COMPLEX(4)' Fortran 77 and ! X' later `ZEXP(X)' `COMPLEX(8) `COMPLEX(8)' GNU extension X' `CDEXP(X)' `COMPLEX(8) `COMPLEX(8)' GNU extension *************** _Specific names_: *** 5310,5316 ****  File: gfortran.info, Node: EXPONENT, Next: FDATE, Prev: EXP, Up: Intrinsic Procedures ! 6.68 `EXPONENT' -- Exponent function ==================================== _Description_: --- 5808,5814 ----  File: gfortran.info, Node: EXPONENT, Next: FDATE, Prev: EXP, Up: Intrinsic Procedures ! 7.70 `EXPONENT' -- Exponent function ==================================== _Description_: *************** _Description_: *** 5318,5324 **** zero the value returned is zero. _Standard_: ! F95 and later _Class_: Elemental function --- 5816,5822 ---- zero the value returned is zero. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 5327,5333 **** `RESULT = EXPONENT(X)' _Arguments_: ! X The type shall be `REAL(*)'. _Return value_: The return value is of type default `INTEGER'. --- 5825,5831 ---- `RESULT = EXPONENT(X)' _Arguments_: ! X The type shall be `REAL'. _Return value_: The return value is of type default `INTEGER'. *************** _Example_: *** 5344,5350 ****  File: gfortran.info, Node: FDATE, Next: FGET, Prev: EXPONENT, Up: Intrinsic Procedures ! 6.69 `FDATE' -- Get the current time as a string ================================================ _Description_: --- 5842,5848 ----  File: gfortran.info, Node: FDATE, Next: FGET, Prev: EXPONENT, Up: Intrinsic Procedures ! 7.71 `FDATE' -- Get the current time as a string ================================================ _Description_: *************** _Description_: *** 5354,5360 **** This intrinsic is provided in both subroutine and function forms; however, only one form can be used in any given program unit. ! DATE is an `INTENT(OUT)' `CHARACTER' variable. _Standard_: GNU extension --- 5852,5858 ---- This intrinsic is provided in both subroutine and function forms; however, only one form can be used in any given program unit. ! DATE is an `INTENT(OUT)' `CHARACTER' variable of the default kind. _Standard_: GNU extension *************** _Syntax_: *** 5367,5373 **** `DATE = FDATE()', (not recommended). _Arguments_: ! DATE The type shall be of type `CHARACTER'. _Return value_: The current date as a string. --- 5865,5872 ---- `DATE = FDATE()', (not recommended). _Arguments_: ! DATE The type shall be of type `CHARACTER' of the ! default kind _Return value_: The current date as a string. *************** _Example_: *** 5388,5410 ****  File: gfortran.info, Node: FLOAT, Next: FLOOR, Prev: FGETC, Up: Intrinsic Procedures ! 6.70 `FLOAT' -- Convert integer to default real =============================================== _Description_: ! `FLOAT(I)' converts the integer I to a default real value. _Standard_: ! F77 and later _Class_: Elemental function _Syntax_: ! `RESULT = FLOAT(I)' _Arguments_: ! I The type shall be `INTEGER(*)'. _Return value_: The return value is of type default `REAL'. --- 5887,5909 ----  File: gfortran.info, Node: FLOAT, Next: FLOOR, Prev: FGETC, Up: Intrinsic Procedures ! 7.72 `FLOAT' -- Convert integer to default real =============================================== _Description_: ! `FLOAT(A)' converts the integer A to a default real value. _Standard_: ! Fortran 77 and later _Class_: Elemental function _Syntax_: ! `RESULT = FLOAT(A)' _Arguments_: ! A The type shall be `INTEGER'. _Return value_: The return value is of type default `REAL'. *************** _See also_: *** 5421,5427 ****  File: gfortran.info, Node: FGET, Next: FGETC, Prev: FDATE, Up: Intrinsic Procedures ! 6.71 `FGET' -- Read a single character in stream mode from stdin ================================================================ _Description_: --- 5920,5926 ----  File: gfortran.info, Node: FGET, Next: FGETC, Prev: FDATE, Up: Intrinsic Procedures ! 7.73 `FGET' -- Read a single character in stream mode from stdin ================================================================ _Description_: *************** _Syntax_: *** 5449,5458 **** `CALL FGET(C [, STATUS])' _Arguments_: ! C The type shall be `CHARACTER'. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, -1 on ! end-of-file, and a system specific positive error code otherwise. _Example_: --- 5948,5957 ---- `CALL FGET(C [, STATUS])' _Arguments_: ! C The type shall be `CHARACTER' and of default ! kind. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, -1 on end-of-file, and a system specific positive error code otherwise. _Example_: *************** _See also_: *** 5476,5482 ****  File: gfortran.info, Node: FGETC, Next: FLOAT, Prev: FGET, Up: Intrinsic Procedures ! 6.72 `FGETC' -- Read a single character in stream mode ====================================================== _Description_: --- 5975,5981 ----  File: gfortran.info, Node: FGETC, Next: FLOAT, Prev: FGET, Up: Intrinsic Procedures ! 7.74 `FGETC' -- Read a single character in stream mode ====================================================== _Description_: *************** _Syntax_: *** 5505,5515 **** _Arguments_: UNIT The type shall be `INTEGER'. ! C The type shall be `CHARACTER'. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, ! -1 on end-of-file and a system specific ! positive error code otherwise. _Example_: PROGRAM test_fgetc --- 6004,6014 ---- _Arguments_: UNIT The type shall be `INTEGER'. ! C The type shall be `CHARACTER' and of default ! kind. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, -1 on end-of-file and a ! system specific positive error code otherwise. _Example_: PROGRAM test_fgetc *************** _See also_: *** 5531,5559 ****  File: gfortran.info, Node: FLOOR, Next: FLUSH, Prev: FLOAT, Up: Intrinsic Procedures ! 6.73 `FLOOR' -- Integer floor function ====================================== _Description_: ! `FLOOR(X)' returns the greatest integer less than or equal to X. _Standard_: ! F95 and later _Class_: Elemental function _Syntax_: ! `RESULT = FLOOR(X [, KIND])' _Arguments_: ! X The type shall be `REAL(*)'. ! KIND (Optional) An `INTEGER(*)' initialization ! expression indicating the kind ! parameter of the result. _Return value_: ! The return value is of type `INTEGER(KIND)' _Example_: program test_floor --- 6030,6059 ----  File: gfortran.info, Node: FLOOR, Next: FLUSH, Prev: FLOAT, Up: Intrinsic Procedures ! 7.75 `FLOOR' -- Integer floor function ====================================== _Description_: ! `FLOOR(A)' returns the greatest integer less than or equal to X. _Standard_: ! Fortran 95 and later _Class_: Elemental function _Syntax_: ! `RESULT = FLOOR(A [, KIND])' _Arguments_: ! A The type shall be `REAL'. ! KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: ! The return value is of type `INTEGER(KIND)' if KIND is present and ! of default-kind `INTEGER' otherwise. _Example_: program test_floor *************** _See also_: *** 5570,5576 ****  File: gfortran.info, Node: FLUSH, Next: FNUM, Prev: FLOOR, Up: Intrinsic Procedures ! 6.74 `FLUSH' -- Flush I/O unit(s) ================================= _Description_: --- 6070,6076 ----  File: gfortran.info, Node: FLUSH, Next: FNUM, Prev: FLOOR, Up: Intrinsic Procedures ! 7.76 `FLUSH' -- Flush I/O unit(s) ================================= _Description_: *************** _Note_: *** 5598,5604 ****  File: gfortran.info, Node: FNUM, Next: FPUT, Prev: FLUSH, Up: Intrinsic Procedures ! 6.75 `FNUM' -- File number function =================================== _Description_: --- 6098,6104 ----  File: gfortran.info, Node: FNUM, Next: FPUT, Prev: FLUSH, Up: Intrinsic Procedures ! 7.77 `FNUM' -- File number function =================================== _Description_: *************** _Example_: *** 5632,5638 ****  File: gfortran.info, Node: FPUT, Next: FPUTC, Prev: FNUM, Up: Intrinsic Procedures ! 6.76 `FPUT' -- Write a single character in stream mode to stdout ================================================================ _Description_: --- 6132,6138 ----  File: gfortran.info, Node: FPUT, Next: FPUTC, Prev: FNUM, Up: Intrinsic Procedures ! 7.78 `FPUT' -- Write a single character in stream mode to stdout ================================================================ _Description_: *************** _Syntax_: *** 5660,5670 **** `CALL FPUT(C [, STATUS])' _Arguments_: ! C The type shall be `CHARACTER'. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, ! -1 on end-of-file and a system specific ! positive error code otherwise. _Example_: PROGRAM test_fput --- 6160,6170 ---- `CALL FPUT(C [, STATUS])' _Arguments_: ! C The type shall be `CHARACTER' and of default ! kind. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, -1 on end-of-file and a ! system specific positive error code otherwise. _Example_: PROGRAM test_fput *************** _See also_: *** 5681,5687 ****  File: gfortran.info, Node: FPUTC, Next: FRACTION, Prev: FPUT, Up: Intrinsic Procedures ! 6.77 `FPUTC' -- Write a single character in stream mode ======================================================= _Description_: --- 6181,6187 ----  File: gfortran.info, Node: FPUTC, Next: FRACTION, Prev: FPUT, Up: Intrinsic Procedures ! 7.79 `FPUTC' -- Write a single character in stream mode ======================================================= _Description_: *************** _Syntax_: *** 5710,5720 **** _Arguments_: UNIT The type shall be `INTEGER'. ! C The type shall be `CHARACTER'. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, ! -1 on end-of-file and a system specific ! positive error code otherwise. _Example_: PROGRAM test_fputc --- 6210,6220 ---- _Arguments_: UNIT The type shall be `INTEGER'. ! C The type shall be `CHARACTER' and of default ! kind. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, -1 on end-of-file and a ! system specific positive error code otherwise. _Example_: PROGRAM test_fputc *************** _See also_: *** 5734,5740 ****  File: gfortran.info, Node: FRACTION, Next: FREE, Prev: FPUTC, Up: Intrinsic Procedures ! 6.78 `FRACTION' -- Fractional part of the model representation ============================================================== _Description_: --- 6234,6240 ----  File: gfortran.info, Node: FRACTION, Next: FREE, Prev: FPUTC, Up: Intrinsic Procedures ! 7.80 `FRACTION' -- Fractional part of the model representation ============================================================== _Description_: *************** _Description_: *** 5742,5748 **** representation of `X'. _Standard_: ! F95 and later _Class_: Elemental function --- 6242,6248 ---- representation of `X'. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Example_: *** 5769,5775 ****  File: gfortran.info, Node: FREE, Next: FSEEK, Prev: FRACTION, Up: Intrinsic Procedures ! 6.79 `FREE' -- Frees memory =========================== _Description_: --- 6269,6275 ----  File: gfortran.info, Node: FREE, Next: FSEEK, Prev: FRACTION, Up: Intrinsic Procedures ! 7.81 `FREE' -- Frees memory =========================== _Description_: *************** _See also_: *** 5805,5811 ****  File: gfortran.info, Node: FSEEK, Next: FSTAT, Prev: FREE, Up: Intrinsic Procedures ! 6.80 `FSEEK' -- Low level file positioning subroutine ===================================================== _Description_: --- 6305,6311 ----  File: gfortran.info, Node: FSEEK, Next: FSTAT, Prev: FREE, Up: Intrinsic Procedures ! 7.82 `FSEEK' -- Low level file positioning subroutine ===================================================== _Description_: *************** _See also_: *** 5875,5881 ****  File: gfortran.info, Node: FSTAT, Next: FTELL, Prev: FSEEK, Up: Intrinsic Procedures ! 6.81 `FSTAT' -- Get file status =============================== _Description_: --- 6375,6381 ----  File: gfortran.info, Node: FSTAT, Next: FTELL, Prev: FSEEK, Up: Intrinsic Procedures ! 7.83 `FSTAT' -- Get file status =============================== _Description_: *************** _Arguments_: *** 5900,5907 **** UNIT An open I/O unit number of type `INTEGER'. BUFF The type shall be `INTEGER(4), DIMENSION(13)'. STATUS (Optional) status flag of type `INTEGER(4)'. ! Returns 0 on success ! and a system specific error code otherwise. _Example_: See *note STAT:: for an example. --- 6400,6407 ---- UNIT An open I/O unit number of type `INTEGER'. BUFF The type shall be `INTEGER(4), DIMENSION(13)'. STATUS (Optional) status flag of type `INTEGER(4)'. ! Returns 0 on success and a system specific ! error code otherwise. _Example_: See *note STAT:: for an example. *************** _See also_: *** 5912,5918 ****  File: gfortran.info, Node: FTELL, Next: GAMMA, Prev: FSTAT, Up: Intrinsic Procedures ! 6.82 `FTELL' -- Current stream position ======================================= _Description_: --- 6412,6418 ----  File: gfortran.info, Node: FTELL, Next: GAMMA, Prev: FSTAT, Up: Intrinsic Procedures ! 7.84 `FTELL' -- Current stream position ======================================= _Description_: *************** _See also_: *** 5953,5959 ****  File: gfortran.info, Node: GAMMA, Next: GERROR, Prev: FTELL, Up: Intrinsic Procedures ! 6.83 `GAMMA' -- Gamma function ============================== _Description_: --- 6453,6459 ----  File: gfortran.info, Node: GAMMA, Next: GERROR, Prev: FTELL, Up: Intrinsic Procedures ! 7.85 `GAMMA' -- Gamma function ============================== _Description_: *************** _Description_: *** 5962,5968 **** function \Gamma(x)=(x-1)!. _Standard_: ! GNU Extension _Class_: Elemental function --- 6462,6468 ---- function \Gamma(x)=(x-1)!. _Standard_: ! Fortran 2008 and later _Class_: Elemental function *************** _Specific names_: *** 5989,6001 **** `DGAMMA(X)' `REAL(8) X' `REAL(8)' GNU Extension _See also_: ! Logarithm of the Gamma function: *note LGAMMA::  File: gfortran.info, Node: GERROR, Next: GETARG, Prev: GAMMA, Up: Intrinsic Procedures ! 6.84 `GERROR' -- Get last system error message ============================================== _Description_: --- 6489,6501 ---- `DGAMMA(X)' `REAL(8) X' `REAL(8)' GNU Extension _See also_: ! Logarithm of the Gamma function: *note LOG_GAMMA::  File: gfortran.info, Node: GERROR, Next: GETARG, Prev: GAMMA, Up: Intrinsic Procedures ! 7.86 `GERROR' -- Get last system error message ============================================== _Description_: *************** _Syntax_: *** 6012,6018 **** `CALL GERROR(RESULT)' _Arguments_: ! RESULT Shall of type `CHARACTER(*)'. _Example_: PROGRAM test_gerror --- 6512,6518 ---- `CALL GERROR(RESULT)' _Arguments_: ! RESULT Shall of type `CHARACTER' and of default _Example_: PROGRAM test_gerror *************** _See also_: *** 6027,6038 ****  File: gfortran.info, Node: GETARG, Next: GET_COMMAND, Prev: GERROR, Up: Intrinsic Procedures ! 6.85 `GETARG' -- Get command line arguments =========================================== _Description_: ! Retrieve the Nth argument that was passed on the command line when ! the containing program was invoked. This intrinsic routine is provided for backwards compatibility with GNU Fortran 77. In new code, programmers should consider the use --- 6527,6538 ----  File: gfortran.info, Node: GETARG, Next: GET_COMMAND, Prev: GERROR, Up: Intrinsic Procedures ! 7.87 `GETARG' -- Get command line arguments =========================================== _Description_: ! Retrieve the POS-th argument that was passed on the command line ! when the containing program was invoked. This intrinsic routine is provided for backwards compatibility with GNU Fortran 77. In new code, programmers should consider the use *************** _Syntax_: *** 6051,6057 **** _Arguments_: POS Shall be of type `INTEGER' and not wider than the default integer kind; POS \geq 0 ! VALUE Shall be of type `CHARACTER(*)'. _Return value_: After `GETARG' returns, the VALUE argument holds the POSth command --- 6551,6559 ---- _Arguments_: POS Shall be of type `INTEGER' and not wider than the default integer kind; POS \geq 0 ! VALUE Shall be of type `CHARACTER' and of default ! kind. ! VALUE Shall be of type `CHARACTER'. _Return value_: After `GETARG' returns, the VALUE argument holds the POSth command *************** _Example_: *** 6075,6087 **** _See also_: GNU Fortran 77 compatibility function: *note IARGC:: ! F2003 functions and subroutines: *note GET_COMMAND::, *note GET_COMMAND_ARGUMENT::, *note COMMAND_ARGUMENT_COUNT::  File: gfortran.info, Node: GET_COMMAND, Next: GET_COMMAND_ARGUMENT, Prev: GETARG, Up: Intrinsic Procedures ! 6.86 `GET_COMMAND' -- Get the entire command line ================================================= _Description_: --- 6577,6589 ---- _See also_: GNU Fortran 77 compatibility function: *note IARGC:: ! Fortran 2003 functions and subroutines: *note GET_COMMAND::, *note GET_COMMAND_ARGUMENT::, *note COMMAND_ARGUMENT_COUNT::  File: gfortran.info, Node: GET_COMMAND, Next: GET_COMMAND_ARGUMENT, Prev: GETARG, Up: Intrinsic Procedures ! 7.88 `GET_COMMAND' -- Get the entire command line ================================================= _Description_: *************** _Description_: *** 6089,6108 **** program. _Standard_: ! F2003 _Class_: Subroutine _Syntax_: ! `CALL GET_COMMAND(CMD)' _Arguments_: ! CMD Shall be of type `CHARACTER(*)'. _Return value_: Stores the entire command line that was used to invoke the program ! in ARG. If ARG is not large enough, the command will be truncated. _Example_: PROGRAM test_get_command --- 6591,6612 ---- program. _Standard_: ! Fortran 2003 and later _Class_: Subroutine _Syntax_: ! `CALL GET_COMMAND(COMMAND)' _Arguments_: ! COMMAND Shall be of type `CHARACTER' and of default ! kind. _Return value_: Stores the entire command line that was used to invoke the program ! in COMMAND. If COMMAND is not large enough, the command will be ! truncated. _Example_: PROGRAM test_get_command *************** _See also_: *** 6117,6149 ****  File: gfortran.info, Node: GET_COMMAND_ARGUMENT, Next: GETCWD, Prev: GET_COMMAND, Up: Intrinsic Procedures ! 6.87 `GET_COMMAND_ARGUMENT' -- Get command line arguments ========================================================= _Description_: ! Retrieve the Nth argument that was passed on the command line when ! the containing program was invoked. _Standard_: ! F2003 _Class_: Subroutine _Syntax_: ! `CALL GET_COMMAND_ARGUMENT(N, ARG)' _Arguments_: ! N Shall be of type `INTEGER(4)', N \geq 0 ! ARG Shall be of type `CHARACTER(*)'. _Return value_: ! After `GET_COMMAND_ARGUMENT' returns, the ARG argument holds the ! Nth command line argument. If ARG can not hold the argument, it is ! truncated to fit the length of ARG. If there are less than N ! arguments specified at the command line, ARG will be filled with ! blanks. If N = 0, ARG is set to the name of the program (on ! systems that support this feature). _Example_: PROGRAM test_get_command_argument --- 6621,6663 ----  File: gfortran.info, Node: GET_COMMAND_ARGUMENT, Next: GETCWD, Prev: GET_COMMAND, Up: Intrinsic Procedures ! 7.89 `GET_COMMAND_ARGUMENT' -- Get command line arguments ========================================================= _Description_: ! Retrieve the NUMBER-th argument that was passed on the command ! line when the containing program was invoked. _Standard_: ! Fortran 2003 and later _Class_: Subroutine _Syntax_: ! `CALL GET_COMMAND_ARGUMENT(NUMBER [, VALUE, LENGTH, STATUS])' _Arguments_: ! NUMBER Shall be a scalar of type `INTEGER(4)', NUMBER ! \geq 0 ! VALUE Shall be a scalar of type `CHARACTER' and of ! default kind. ! LENGTH (Option) Shall be a scalar of type ! `INTEGER(4)'. ! STATUS (Option) Shall be a scalar of type ! `INTEGER(4)'. _Return value_: ! After `GET_COMMAND_ARGUMENT' returns, the VALUE argument holds the ! NUMBER-th command line argument. If VALUE can not hold the ! argument, it is truncated to fit the length of VALUE. If there are ! less than NUMBER arguments specified at the command line, VALUE ! will be filled with blanks. If NUMBER = 0, VALUE is set to the ! name of the program (on systems that support this feature). The ! LENGTH argument contains the length of the NUMBER-th command line ! argument. If the argument retrieval fails, STATUS is a positive ! number; if VALUE contains a truncated command line argument, ! STATUS is -1; and otherwise the STATUS is zero. _Example_: PROGRAM test_get_command_argument *************** _See also_: *** 6166,6172 ****  File: gfortran.info, Node: GETCWD, Next: GETENV, Prev: GET_COMMAND_ARGUMENT, Up: Intrinsic Procedures ! 6.88 `GETCWD' -- Get current working directory ============================================== _Description_: --- 6680,6686 ----  File: gfortran.info, Node: GETCWD, Next: GETENV, Prev: GET_COMMAND_ARGUMENT, Up: Intrinsic Procedures ! 7.90 `GETCWD' -- Get current working directory ============================================== _Description_: *************** _Class_: *** 6182,6194 **** Subroutine, function _Syntax_: ! `CALL GETCWD(CWD [, STATUS])' _Arguments_: ! CWD The type shall be `CHARACTER(*)'. STATUS (Optional) status flag. Returns 0 on success, ! a system specific and ! nonzero error code otherwise. _Example_: PROGRAM test_getcwd --- 6696,6709 ---- Subroutine, function _Syntax_: ! `CALL GETCWD(C [, STATUS])' _Arguments_: ! C The type shall be `CHARACTER' and of default ! kind. STATUS (Optional) status flag. Returns 0 on success, ! a system specific and nonzero error code ! otherwise. _Example_: PROGRAM test_getcwd *************** _See also_: *** 6203,6213 ****  File: gfortran.info, Node: GETENV, Next: GET_ENVIRONMENT_VARIABLE, Prev: GETCWD, Up: Intrinsic Procedures ! 6.89 `GETENV' -- Get an environmental variable ============================================== _Description_: ! Get the VALUE of the environmental variable ENVVAR. This intrinsic routine is provided for backwards compatibility with GNU Fortran 77. In new code, programmers should consider the use --- 6718,6728 ----  File: gfortran.info, Node: GETENV, Next: GET_ENVIRONMENT_VARIABLE, Prev: GETCWD, Up: Intrinsic Procedures ! 7.91 `GETENV' -- Get an environmental variable ============================================== _Description_: ! Get the VALUE of the environmental variable NAME. This intrinsic routine is provided for backwards compatibility with GNU Fortran 77. In new code, programmers should consider the use *************** _Class_: *** 6221,6236 **** Subroutine _Syntax_: ! `CALL GETENV(ENVVAR, VALUE)' _Arguments_: ! ENVVAR Shall be of type `CHARACTER(*)'. ! VALUE Shall be of type `CHARACTER(*)'. _Return value_: ! Stores the value of ENVVAR in VALUE. If VALUE is not large enough ! to hold the data, it is truncated. If ENVVAR is not set, VALUE ! will be filled with blanks. _Example_: PROGRAM test_getenv --- 6736,6753 ---- Subroutine _Syntax_: ! `CALL GETENV(NAME, VALUE)' _Arguments_: ! NAME Shall be of type `CHARACTER' and of default ! kind. ! VALUE Shall be of type `CHARACTER' and of default ! kind. _Return value_: ! Stores the value of NAME in VALUE. If VALUE is not large enough to ! hold the data, it is truncated. If NAME is not set, VALUE will be ! filled with blanks. _Example_: PROGRAM test_getenv *************** _See also_: *** 6245,6273 ****  File: gfortran.info, Node: GET_ENVIRONMENT_VARIABLE, Next: GETGID, Prev: GETENV, Up: Intrinsic Procedures ! 6.90 `GET_ENVIRONMENT_VARIABLE' -- Get an environmental variable ================================================================ _Description_: ! Get the VALUE of the environmental variable ENVVAR. _Standard_: ! F2003 _Class_: Subroutine _Syntax_: ! `CALL GET_ENVIRONMENT_VARIABLE(ENVVAR, VALUE)' _Arguments_: ! ENVVAR Shall be of type `CHARACTER(*)'. ! VALUE Shall be of type `CHARACTER(*)'. _Return value_: ! Stores the value of ENVVAR in VALUE. If VALUE is not large enough ! to hold the data, it is truncated. If ENVVAR is not set, VALUE ! will be filled with blanks. _Example_: PROGRAM test_getenv --- 6762,6802 ----  File: gfortran.info, Node: GET_ENVIRONMENT_VARIABLE, Next: GETGID, Prev: GETENV, Up: Intrinsic Procedures ! 7.92 `GET_ENVIRONMENT_VARIABLE' -- Get an environmental variable ================================================================ _Description_: ! Get the VALUE of the environmental variable NAME. _Standard_: ! Fortran 2003 and later _Class_: Subroutine _Syntax_: ! `CALL GET_ENVIRONMENT_VARIABLE(NAME[, VALUE, LENGTH, STATUS, ! TRIM_NAME)' _Arguments_: ! NAME Shall be a scalar of type `CHARACTER(1)'. ! VALUE Shall be a scalar of type `CHARACTER(1)'. ! LENGTH Shall be a scalar of type `INTEGER(4)'. ! STATUS Shall be a scalar of type `INTEGER(4)'. ! TRIM_NAME Shall be a scalar of type `LOGICAL(4)'. _Return value_: ! Stores the value of NAME in VALUE. If VALUE is not large enough to ! hold the data, it is truncated. If NAME is not set, VALUE will be ! filled with blanks. Argument LENGTH contains the length needed for ! storing the environment variable NAME or zero if it is not ! present. STATUS is -1 if VALUE is present but too short for the ! environment variable; it is 1 if the environment variable does not ! exist and 2 if the processor does not support environment ! variables; in all other cases STATUS is zero. If TRIM_NAME is ! present with the value `.FALSE.', the trailing blanks in NAME are ! significant; otherwise they are not part of the environment ! variable name. _Example_: PROGRAM test_getenv *************** _Example_: *** 6279,6285 ****  File: gfortran.info, Node: GETGID, Next: GETLOG, Prev: GET_ENVIRONMENT_VARIABLE, Up: Intrinsic Procedures ! 6.91 `GETGID' -- Group ID function ================================== _Description_: --- 6808,6814 ----  File: gfortran.info, Node: GETGID, Next: GETLOG, Prev: GET_ENVIRONMENT_VARIABLE, Up: Intrinsic Procedures ! 7.93 `GETGID' -- Group ID function ================================== _Description_: *************** _See also_: *** 6306,6312 ****  File: gfortran.info, Node: GETLOG, Next: GETPID, Prev: GETGID, Up: Intrinsic Procedures ! 6.92 `GETLOG' -- Get login name =============================== _Description_: --- 6835,6841 ----  File: gfortran.info, Node: GETLOG, Next: GETPID, Prev: GETGID, Up: Intrinsic Procedures ! 7.94 `GETLOG' -- Get login name =============================== _Description_: *************** _Class_: *** 6319,6328 **** Subroutine _Syntax_: ! `CALL GETLOG(LOGIN)' _Arguments_: ! LOGIN Shall be of type `CHARACTER(*)'. _Return value_: Stores the current user name in LOGIN. (On systems where POSIX --- 6848,6858 ---- Subroutine _Syntax_: ! `CALL GETLOG(C)' _Arguments_: ! C Shall be of type `CHARACTER' and of default ! kind. _Return value_: Stores the current user name in LOGIN. (On systems where POSIX *************** _See also_: *** 6343,6349 ****  File: gfortran.info, Node: GETPID, Next: GETUID, Prev: GETLOG, Up: Intrinsic Procedures ! 6.93 `GETPID' -- Process ID function ==================================== _Description_: --- 6873,6879 ----  File: gfortran.info, Node: GETPID, Next: GETUID, Prev: GETLOG, Up: Intrinsic Procedures ! 7.95 `GETPID' -- Process ID function ==================================== _Description_: *************** _See also_: *** 6374,6380 ****  File: gfortran.info, Node: GETUID, Next: GMTIME, Prev: GETPID, Up: Intrinsic Procedures ! 6.94 `GETUID' -- User ID function ================================= _Description_: --- 6904,6910 ----  File: gfortran.info, Node: GETUID, Next: GMTIME, Prev: GETPID, Up: Intrinsic Procedures ! 7.96 `GETUID' -- User ID function ================================= _Description_: *************** _See also_: *** 6401,6412 ****  File: gfortran.info, Node: GMTIME, Next: HOSTNM, Prev: GETUID, Up: Intrinsic Procedures ! 6.95 `GMTIME' -- Convert time to GMT info ========================================= _Description_: ! Given a system time value STIME (as provided by the `TIME8()' ! intrinsic), fills TARRAY with values extracted from it appropriate to the UTC time zone (Universal Coordinated Time, also known in some countries as GMT, Greenwich Mean Time), using `gmtime(3)'. --- 6931,6942 ----  File: gfortran.info, Node: GMTIME, Next: HOSTNM, Prev: GETUID, Up: Intrinsic Procedures ! 7.97 `GMTIME' -- Convert time to GMT info ========================================= _Description_: ! Given a system time value TIME (as provided by the `TIME8()' ! intrinsic), fills VALUES with values extracted from it appropriate to the UTC time zone (Universal Coordinated Time, also known in some countries as GMT, Greenwich Mean Time), using `gmtime(3)'. *************** _Class_: *** 6417,6435 **** Subroutine _Syntax_: ! `CALL GMTIME(STIME, TARRAY)' _Arguments_: ! STIME An `INTEGER(*)' scalar expression ! corresponding to a system time, with ! `INTENT(IN)'. ! TARRAY A default `INTEGER' array with 9 elements, ! with `INTENT(OUT)'. _Return value_: ! The elements of TARRAY are assigned as follows: 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap ! seconds 2. Minutes after the hour, range 0-59 --- 6947,6964 ---- Subroutine _Syntax_: ! `CALL GMTIME(TIME, VALUES)' _Arguments_: ! TIME An `INTEGER' scalar expression corresponding ! to a system time, with `INTENT(IN)'. ! VALUES A default `INTEGER' array with 9 elements, ! with `INTENT(OUT)'. _Return value_: ! The elements of VALUES are assigned as follows: 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap ! seconds 2. Minutes after the hour, range 0-59 *************** _Return value_: *** 6446,6453 **** 8. Days since January 1 9. Daylight savings indicator: positive if daylight savings is in ! effect, zero if not, and negative if the information is ! not available. _See also_: *note CTIME::, *note LTIME::, *note TIME::, *note TIME8:: --- 6975,6982 ---- 8. Days since January 1 9. Daylight savings indicator: positive if daylight savings is in ! effect, zero if not, and negative if the information is not ! available. _See also_: *note CTIME::, *note LTIME::, *note TIME::, *note TIME8:: *************** _See also_: *** 6456,6462 ****  File: gfortran.info, Node: HOSTNM, Next: HUGE, Prev: GMTIME, Up: Intrinsic Procedures ! 6.96 `HOSTNM' -- Get system host name ===================================== _Description_: --- 6985,6991 ----  File: gfortran.info, Node: HOSTNM, Next: HUGE, Prev: GMTIME, Up: Intrinsic Procedures ! 7.98 `HOSTNM' -- Get system host name ===================================== _Description_: *************** _Class_: *** 6473,6487 **** Subroutine, function _Syntax_: ! `CALL HOSTNM(NAME[, STATUS])' `STATUS = HOSTNM(NAME)' _Arguments_: ! NAME Shall of type `CHARACTER(*)'. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, or a ! system specific error ! code otherwise. _Return value_: In either syntax, NAME is set to the current hostname if it can be --- 7002,7015 ---- Subroutine, function _Syntax_: ! `CALL HOSTNM(C [, STATUS])' `STATUS = HOSTNM(NAME)' _Arguments_: ! C Shall of type `CHARACTER' and of default kind. STATUS (Optional) status flag of type `INTEGER'. ! Returns 0 on success, or a system specific ! error code otherwise. _Return value_: In either syntax, NAME is set to the current hostname if it can be *************** _Return value_: *** 6489,6497 ****  ! File: gfortran.info, Node: HUGE, Next: IACHAR, Prev: HOSTNM, Up: Intrinsic Procedures ! 6.97 `HUGE' -- Largest number of a kind ======================================= _Description_: --- 7017,7025 ----  ! File: gfortran.info, Node: HUGE, Next: HYPOT, Prev: HOSTNM, Up: Intrinsic Procedures ! 7.99 `HUGE' -- Largest number of a kind ======================================= _Description_: *************** _Description_: *** 6499,6505 **** the model of the type of `X'. _Standard_: ! F95 and later _Class_: Inquiry function --- 7027,7033 ---- the model of the type of `X'. _Standard_: ! Fortran 95 and later _Class_: Inquiry function *************** _Example_: *** 6520,6536 **** end program test_huge_tiny  ! File: gfortran.info, Node: IACHAR, Next: IAND, Prev: HUGE, Up: Intrinsic Procedures ! 6.98 `IACHAR' -- Code in ASCII collating sequence ! ================================================= _Description_: `IACHAR(C)' returns the code for the ASCII character in the first character position of `C'. _Standard_: ! F95 and later _Class_: Elemental function --- 7048,7097 ---- end program test_huge_tiny  ! File: gfortran.info, Node: HYPOT, Next: IACHAR, Prev: HUGE, Up: Intrinsic Procedures ! 7.100 `HYPOT' -- Euclidean distance function ! ============================================ ! ! _Description_: ! `HYPOT(X,Y)' is the Euclidean distance function. It is equal to ! \sqrtX^2 + Y^2, without undue underflow or overflow. ! ! _Standard_: ! Fortran 2008 and later ! ! _Class_: ! Elemental function ! ! _Syntax_: ! `RESULT = HYPOT(X, Y)' ! ! _Arguments_: ! X The type shall be `REAL'. ! Y The type and kind type parameter shall be the ! same as X. ! ! _Return value_: ! The return value has the same type and kind type parameter as X. ! ! _Example_: ! program test_hypot ! real(4) :: x = 1.e0_4, y = 0.5e0_4 ! x = hypot(x,y) ! end program test_hypot ! !  ! File: gfortran.info, Node: IACHAR, Next: IAND, Prev: HYPOT, Up: Intrinsic Procedures ! ! 7.101 `IACHAR' -- Code in ASCII collating sequence ! ================================================== _Description_: `IACHAR(C)' returns the code for the ASCII character in the first character position of `C'. _Standard_: ! Fortran 95 and later, with KIND argument Fortran 2003 and later _Class_: Elemental function *************** _Arguments_: *** 6542,6549 **** C Shall be a scalar `CHARACTER', with `INTENT(IN)' KIND (Optional) An `INTEGER' initialization ! expression indicating the kind ! parameter of the result. _Return value_: The return value is of type `INTEGER' and of kind KIND. If KIND is --- 7103,7110 ---- C Shall be a scalar `CHARACTER', with `INTENT(IN)' KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: The return value is of type `INTEGER' and of kind KIND. If KIND is *************** _See also_: *** 6566,6579 ****  File: gfortran.info, Node: IAND, Next: IARGC, Prev: IACHAR, Up: Intrinsic Procedures ! 6.99 `IAND' -- Bitwise logical and ! ================================== _Description_: Bitwise logical `AND'. _Standard_: ! F95 and later _Class_: Elemental function --- 7127,7140 ----  File: gfortran.info, Node: IAND, Next: IARGC, Prev: IACHAR, Up: Intrinsic Procedures ! 7.102 `IAND' -- Bitwise logical and ! =================================== _Description_: Bitwise logical `AND'. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 6582,6596 **** `RESULT = IAND(I, J)' _Arguments_: ! I The type shall be `INTEGER(*)'. ! J The type shall be `INTEGER(*)', of the same ! kind as I. (As a GNU extension, different ! kinds are also permitted.) _Return value_: ! The return type is `INTEGER(*)', of the same kind as the ! arguments. (If the argument kinds differ, it is of the same kind ! as the larger argument.) _Example_: PROGRAM test_iand --- 7143,7157 ---- `RESULT = IAND(I, J)' _Arguments_: ! I The type shall be `INTEGER'. ! J The type shall be `INTEGER', of the same kind ! as I. (As a GNU extension, different kinds ! are also permitted.) _Return value_: ! The return type is `INTEGER', of the same kind as the arguments. ! (If the argument kinds differ, it is of the same kind as the ! larger argument.) _Example_: PROGRAM test_iand *************** _See also_: *** 6607,6613 ****  File: gfortran.info, Node: IARGC, Next: IBCLR, Prev: IAND, Up: Intrinsic Procedures ! 6.100 `IARGC' -- Get the number of command line arguments ========================================================= _Description_: --- 7168,7174 ----  File: gfortran.info, Node: IARGC, Next: IBCLR, Prev: IAND, Up: Intrinsic Procedures ! 7.103 `IARGC' -- Get the number of command line arguments ========================================================= _Description_: *************** _Example_: *** 6640,6652 **** _See also_: GNU Fortran 77 compatibility subroutine: *note GETARG:: ! F2003 functions and subroutines: *note GET_COMMAND::, *note GET_COMMAND_ARGUMENT::, *note COMMAND_ARGUMENT_COUNT::  File: gfortran.info, Node: IBCLR, Next: IBITS, Prev: IARGC, Up: Intrinsic Procedures ! 6.101 `IBCLR' -- Clear bit ========================== _Description_: --- 7201,7213 ---- _See also_: GNU Fortran 77 compatibility subroutine: *note GETARG:: ! Fortran 2003 functions and subroutines: *note GET_COMMAND::, *note GET_COMMAND_ARGUMENT::, *note COMMAND_ARGUMENT_COUNT::  File: gfortran.info, Node: IBCLR, Next: IBITS, Prev: IARGC, Up: Intrinsic Procedures ! 7.104 `IBCLR' -- Clear bit ========================== _Description_: *************** _Description_: *** 6654,6660 **** zero. _Standard_: ! F95 and later _Class_: Elemental function --- 7215,7221 ---- zero. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 6663,6673 **** `RESULT = IBCLR(I, POS)' _Arguments_: ! I The type shall be `INTEGER(*)'. ! POS The type shall be `INTEGER(*)'. _Return value_: ! The return value is of type `INTEGER(*)' and of the same kind as I. _See also_: *note IBITS::, *note IBSET::, *note IAND::, *note IOR::, *note --- 7224,7234 ---- `RESULT = IBCLR(I, POS)' _Arguments_: ! I The type shall be `INTEGER'. ! POS The type shall be `INTEGER'. _Return value_: ! The return value is of type `INTEGER' and of the same kind as I. _See also_: *note IBITS::, *note IBSET::, *note IAND::, *note IOR::, *note *************** _See also_: *** 6677,6683 ****  File: gfortran.info, Node: IBITS, Next: IBSET, Prev: IBCLR, Up: Intrinsic Procedures ! 6.102 `IBITS' -- Bit extraction =============================== _Description_: --- 7238,7244 ----  File: gfortran.info, Node: IBITS, Next: IBSET, Prev: IBCLR, Up: Intrinsic Procedures ! 7.105 `IBITS' -- Bit extraction =============================== _Description_: *************** _Description_: *** 6687,6693 **** `POS+LEN' must be less than or equal to the value `BIT_SIZE(I)'. _Standard_: ! F95 and later _Class_: Elemental function --- 7248,7254 ---- `POS+LEN' must be less than or equal to the value `BIT_SIZE(I)'. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 6696,6707 **** `RESULT = IBITS(I, POS, LEN)' _Arguments_: ! I The type shall be `INTEGER(*)'. ! POS The type shall be `INTEGER(*)'. ! LEN The type shall be `INTEGER(*)'. _Return value_: ! The return value is of type `INTEGER(*)' and of the same kind as I. _See also_: *note BIT_SIZE::, *note IBCLR::, *note IBSET::, *note IAND::, --- 7257,7268 ---- `RESULT = IBITS(I, POS, LEN)' _Arguments_: ! I The type shall be `INTEGER'. ! POS The type shall be `INTEGER'. ! LEN The type shall be `INTEGER'. _Return value_: ! The return value is of type `INTEGER' and of the same kind as I. _See also_: *note BIT_SIZE::, *note IBCLR::, *note IBSET::, *note IAND::, *************** _See also_: *** 6710,6716 ****  File: gfortran.info, Node: IBSET, Next: ICHAR, Prev: IBITS, Up: Intrinsic Procedures ! 6.103 `IBSET' -- Set bit ======================== _Description_: --- 7271,7277 ----  File: gfortran.info, Node: IBSET, Next: ICHAR, Prev: IBITS, Up: Intrinsic Procedures ! 7.106 `IBSET' -- Set bit ======================== _Description_: *************** _Description_: *** 6718,6724 **** one. _Standard_: ! F95 and later _Class_: Elemental function --- 7279,7285 ---- one. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 6727,6737 **** `RESULT = IBSET(I, POS)' _Arguments_: ! I The type shall be `INTEGER(*)'. ! POS The type shall be `INTEGER(*)'. _Return value_: ! The return value is of type `INTEGER(*)' and of the same kind as I. _See also_: *note IBCLR::, *note IBITS::, *note IAND::, *note IOR::, *note --- 7288,7298 ---- `RESULT = IBSET(I, POS)' _Arguments_: ! I The type shall be `INTEGER'. ! POS The type shall be `INTEGER'. _Return value_: ! The return value is of type `INTEGER' and of the same kind as I. _See also_: *note IBCLR::, *note IBITS::, *note IAND::, *note IOR::, *note *************** _See also_: *** 6741,6747 ****  File: gfortran.info, Node: ICHAR, Next: IDATE, Prev: IBSET, Up: Intrinsic Procedures ! 6.104 `ICHAR' -- Character-to-integer conversion function ========================================================= _Description_: --- 7302,7308 ----  File: gfortran.info, Node: ICHAR, Next: IDATE, Prev: IBSET, Up: Intrinsic Procedures ! 7.107 `ICHAR' -- Character-to-integer conversion function ========================================================= _Description_: *************** _Description_: *** 6751,6757 **** necessarily the same across different GNU Fortran implementations. _Standard_: ! F95 and later _Class_: Elemental function --- 7312,7318 ---- necessarily the same across different GNU Fortran implementations. _Standard_: ! Fortan 95 and later, with KIND argument Fortran 2003 and later _Class_: Elemental function *************** _Arguments_: *** 6763,6770 **** C Shall be a scalar `CHARACTER', with `INTENT(IN)' KIND (Optional) An `INTEGER' initialization ! expression indicating the kind ! parameter of the result. _Return value_: The return value is of type `INTEGER' and of kind KIND. If KIND is --- 7324,7331 ---- C Shall be a scalar `CHARACTER', with `INTENT(IN)' KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: The return value is of type `INTEGER' and of kind KIND. If KIND is *************** _See also_: *** 6803,6809 ****  File: gfortran.info, Node: IDATE, Next: IEOR, Prev: ICHAR, Up: Intrinsic Procedures ! 6.105 `IDATE' -- Get current local time subroutine (day/month/year) =================================================================== _Description_: --- 7364,7370 ----  File: gfortran.info, Node: IDATE, Next: IEOR, Prev: ICHAR, Up: Intrinsic Procedures ! 7.108 `IDATE' -- Get current local time subroutine (day/month/year) =================================================================== _Description_: *************** _Class_: *** 6819,6832 **** Subroutine _Syntax_: ! `CALL IDATE(TARRAY)' _Arguments_: ! TARRAY The type shall be `INTEGER, DIMENSION(3)' and the kind shall be the default integer kind. _Return value_: ! Does not return. _Example_: program test_idate --- 7380,7393 ---- Subroutine _Syntax_: ! `CALL IDATE(VALUES)' _Arguments_: ! VALUES The type shall be `INTEGER, DIMENSION(3)' and the kind shall be the default integer kind. _Return value_: ! Does not return anything. _Example_: program test_idate *************** _Example_: *** 6840,6853 ****  File: gfortran.info, Node: IEOR, Next: IERRNO, Prev: IDATE, Up: Intrinsic Procedures ! 6.106 `IEOR' -- Bitwise logical exclusive or ============================================ _Description_: `IEOR' returns the bitwise boolean exclusive-OR of I and J. _Standard_: ! F95 and later _Class_: Elemental function --- 7401,7414 ----  File: gfortran.info, Node: IEOR, Next: IERRNO, Prev: IDATE, Up: Intrinsic Procedures ! 7.109 `IEOR' -- Bitwise logical exclusive or ============================================ _Description_: `IEOR' returns the bitwise boolean exclusive-OR of I and J. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 6856,6870 **** `RESULT = IEOR(I, J)' _Arguments_: ! I The type shall be `INTEGER(*)'. ! J The type shall be `INTEGER(*)', of the same ! kind as I. (As a GNU extension, different ! kinds are also permitted.) _Return value_: ! The return type is `INTEGER(*)', of the same kind as the ! arguments. (If the argument kinds differ, it is of the same kind ! as the larger argument.) _See also_: *note IOR::, *note IAND::, *note IBITS::, *note IBSET::, *note --- 7417,7431 ---- `RESULT = IEOR(I, J)' _Arguments_: ! I The type shall be `INTEGER'. ! J The type shall be `INTEGER', of the same kind ! as I. (As a GNU extension, different kinds ! are also permitted.) _Return value_: ! The return type is `INTEGER', of the same kind as the arguments. ! (If the argument kinds differ, it is of the same kind as the ! larger argument.) _See also_: *note IOR::, *note IAND::, *note IBITS::, *note IBSET::, *note *************** _See also_: *** 6873,6879 ****  File: gfortran.info, Node: IERRNO, Next: INDEX intrinsic, Prev: IEOR, Up: Intrinsic Procedures ! 6.107 `IERRNO' -- Get the last system error number ================================================== _Description_: --- 7434,7440 ----  File: gfortran.info, Node: IERRNO, Next: INDEX intrinsic, Prev: IEOR, Up: Intrinsic Procedures ! 7.110 `IERRNO' -- Get the last system error number ================================================== _Description_: *************** _See also_: *** 6902,6908 ****  File: gfortran.info, Node: INDEX intrinsic, Next: INT, Prev: IERRNO, Up: Intrinsic Procedures ! 6.108 `INDEX' -- Position of a substring within a string ======================================================== _Description_: --- 7463,7469 ----  File: gfortran.info, Node: INDEX intrinsic, Next: INT, Prev: IERRNO, Up: Intrinsic Procedures ! 7.111 `INDEX' -- Position of a substring within a string ======================================================== _Description_: *************** _Description_: *** 6913,6919 **** last occurrence rather than the first. _Standard_: ! F77 and later _Class_: Elemental function --- 7474,7480 ---- last occurrence rather than the first. _Standard_: ! Fortran 77 and later, with KIND argument Fortran 2003 and later _Class_: Elemental function *************** _Syntax_: *** 6922,6936 **** `RESULT = INDEX(STRING, SUBSTRING [, BACK [, KIND]])' _Arguments_: ! STRING Shall be a scalar `CHARACTER(*)', with `INTENT(IN)' ! SUBSTRING Shall be a scalar `CHARACTER(*)', with `INTENT(IN)' ! BACK (Optional) Shall be a scalar `LOGICAL(*)', with `INTENT(IN)' KIND (Optional) An `INTEGER' initialization ! expression indicating the kind ! parameter of the result. _Return value_: The return value is of type `INTEGER' and of kind KIND. If KIND is --- 7483,7497 ---- `RESULT = INDEX(STRING, SUBSTRING [, BACK [, KIND]])' _Arguments_: ! STRING Shall be a scalar `CHARACTER', with `INTENT(IN)' ! SUBSTRING Shall be a scalar `CHARACTER', with `INTENT(IN)' ! BACK (Optional) Shall be a scalar `LOGICAL', with `INTENT(IN)' KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: The return value is of type `INTEGER' and of kind KIND. If KIND is *************** _See also_: *** 6942,6955 ****  File: gfortran.info, Node: INT, Next: INT2, Prev: INDEX intrinsic, Up: Intrinsic Procedures ! 6.109 `INT' -- Convert to integer type ====================================== _Description_: Convert to integer type _Standard_: ! F77 and later _Class_: Elemental function --- 7503,7516 ----  File: gfortran.info, Node: INT, Next: INT2, Prev: INDEX intrinsic, Up: Intrinsic Procedures ! 7.112 `INT' -- Convert to integer type ====================================== _Description_: Convert to integer type _Standard_: ! Fortran 77 and later _Class_: Elemental function *************** _Syntax_: *** 6958,6985 **** `RESULT = INT(A [, KIND))' _Arguments_: ! A Shall be of type `INTEGER(*)', ! `REAL(*)', or `COMPLEX(*)'. ! KIND (Optional) An `INTEGER(*)' initialization ! expression indicating the kind ! parameter of the result. _Return value_: ! These functions return a `INTEGER(*)' variable or array under the following rules: (A) ! If A is of type `INTEGER(*)', `INT(A) = A' (B) ! If A is of type `REAL(*)' and |A| < 1, `INT(A)' equals `0'. ! If |A| \geq 1, then `INT(A)' equals the largest integer that does not exceed the range of A and whose sign is the same as the sign of A. (C) ! If A is of type `COMPLEX(*)', rule B is applied to the real ! part of A. _Example_: program test_int --- 7519,7546 ---- `RESULT = INT(A [, KIND))' _Arguments_: ! A Shall be of type `INTEGER', `REAL', or ! `COMPLEX'. ! KIND (Optional) An `INTEGER' initialization ! expression indicating the kind parameter of ! the result. _Return value_: ! These functions return a `INTEGER' variable or array under the following rules: (A) ! If A is of type `INTEGER', `INT(A) = A' (B) ! If A is of type `REAL' and |A| < 1, `INT(A)' equals `0'. If ! |A| \geq 1, then `INT(A)' equals the largest integer that does not exceed the range of A and whose sign is the same as the sign of A. (C) ! If A is of type `COMPLEX', rule B is applied to the real part ! of A. _Example_: program test_int *************** _Example_: *** 6991,7004 **** _Specific names_: Name Argument Return type Standard ! `IFIX(A)' `REAL(4) A' `INTEGER' F77 and later ! `IDINT(A)' `REAL(8) A' `INTEGER' F77 and later  File: gfortran.info, Node: INT2, Next: INT8, Prev: INT, Up: Intrinsic Procedures ! 6.110 `INT2' -- Convert to 16-bit integer type ============================================== _Description_: --- 7552,7567 ---- _Specific names_: Name Argument Return type Standard ! `IFIX(A)' `REAL(4) A' `INTEGER' Fortran 77 and ! later ! `IDINT(A)' `REAL(8) A' `INTEGER' Fortran 77 and ! later  File: gfortran.info, Node: INT2, Next: INT8, Prev: INT, Up: Intrinsic Procedures ! 7.113 `INT2' -- Convert to 16-bit integer type ============================================== _Description_: *************** _Description_: *** 7009,7015 **** The `SHORT' intrinsic is equivalent to `INT2'. _Standard_: ! GNU extension. _Class_: Elemental function --- 7572,7578 ---- The `SHORT' intrinsic is equivalent to `INT2'. _Standard_: ! GNU extension _Class_: Elemental function *************** _Syntax_: *** 7018,7025 **** `RESULT = INT2(A)' _Arguments_: ! A Shall be of type `INTEGER(*)', ! `REAL(*)', or `COMPLEX(*)'. _Return value_: The return value is a `INTEGER(2)' variable. --- 7581,7588 ---- `RESULT = INT2(A)' _Arguments_: ! A Shall be of type `INTEGER', `REAL', or ! `COMPLEX'. _Return value_: The return value is a `INTEGER(2)' variable. *************** _See also_: *** 7030,7036 ****  File: gfortran.info, Node: INT8, Next: IOR, Prev: INT2, Up: Intrinsic Procedures ! 6.111 `INT8' -- Convert to 64-bit integer type ============================================== _Description_: --- 7593,7599 ----  File: gfortran.info, Node: INT8, Next: IOR, Prev: INT2, Up: Intrinsic Procedures ! 7.114 `INT8' -- Convert to 64-bit integer type ============================================== _Description_: *************** _Description_: *** 7039,7045 **** and is only included for backwards compatibility. _Standard_: ! GNU extension. _Class_: Elemental function --- 7602,7608 ---- and is only included for backwards compatibility. _Standard_: ! GNU extension _Class_: Elemental function *************** _Syntax_: *** 7048,7055 **** `RESULT = INT8(A)' _Arguments_: ! A Shall be of type `INTEGER(*)', ! `REAL(*)', or `COMPLEX(*)'. _Return value_: The return value is a `INTEGER(8)' variable. --- 7611,7618 ---- `RESULT = INT8(A)' _Arguments_: ! A Shall be of type `INTEGER', `REAL', or ! `COMPLEX'. _Return value_: The return value is a `INTEGER(8)' variable. *************** _See also_: *** 7060,7073 ****  File: gfortran.info, Node: IOR, Next: IRAND, Prev: INT8, Up: Intrinsic Procedures ! 6.112 `IOR' -- Bitwise logical or ================================= _Description_: `IOR' returns the bitwise boolean inclusive-OR of I and J. _Standard_: ! F95 and later _Class_: Elemental function --- 7623,7636 ----  File: gfortran.info, Node: IOR, Next: IRAND, Prev: INT8, Up: Intrinsic Procedures ! 7.115 `IOR' -- Bitwise logical or ================================= _Description_: `IOR' returns the bitwise boolean inclusive-OR of I and J. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 7076,7090 **** `RESULT = IOR(I, J)' _Arguments_: ! I The type shall be `INTEGER(*)'. ! J The type shall be `INTEGER(*)', of the same ! kind as I. (As a GNU extension, different ! kinds are also permitted.) _Return value_: ! The return type is `INTEGER(*)', of the same kind as the ! arguments. (If the argument kinds differ, it is of the same kind ! as the larger argument.) _See also_: *note IEOR::, *note IAND::, *note IBITS::, *note IBSET::, *note --- 7639,7653 ---- `RESULT = IOR(I, J)' _Arguments_: ! I The type shall be `INTEGER'. ! J The type shall be `INTEGER', of the same kind ! as I. (As a GNU extension, different kinds ! are also permitted.) _Return value_: ! The return type is `INTEGER', of the same kind as the arguments. ! (If the argument kinds differ, it is of the same kind as the ! larger argument.) _See also_: *note IEOR::, *note IAND::, *note IBITS::, *note IBSET::, *note *************** _See also_: *** 7093,7099 ****  File: gfortran.info, Node: IRAND, Next: IS_IOSTAT_END, Prev: IOR, Up: Intrinsic Procedures ! 6.113 `IRAND' -- Integer pseudo-random number ============================================= _Description_: --- 7656,7662 ----  File: gfortran.info, Node: IRAND, Next: IS_IOSTAT_END, Prev: IOR, Up: Intrinsic Procedures ! 7.116 `IRAND' -- Integer pseudo-random number ============================================= _Description_: *************** _Class_: *** 7116,7125 **** Function _Syntax_: ! `RESULT = IRAND(FLAG)' _Arguments_: ! FLAG Shall be a scalar `INTEGER' of kind 4. _Return value_: The return value is of `INTEGER(kind=4)' type. --- 7679,7688 ---- Function _Syntax_: ! `RESULT = IRAND(I)' _Arguments_: ! I Shall be a scalar `INTEGER' of kind 4. _Return value_: The return value is of `INTEGER(kind=4)' type. *************** _Example_: *** 7137,7143 ****  File: gfortran.info, Node: IS_IOSTAT_END, Next: IS_IOSTAT_EOR, Prev: IRAND, Up: Intrinsic Procedures ! 6.114 `IS_IOSTAT_END' -- Test for end-of-file value =================================================== _Description_: --- 7700,7706 ----  File: gfortran.info, Node: IS_IOSTAT_END, Next: IS_IOSTAT_EOR, Prev: IRAND, Up: Intrinsic Procedures ! 7.117 `IS_IOSTAT_END' -- Test for end-of-file value =================================================== _Description_: *************** _Description_: *** 7147,7153 **** `ISO_FORTRAN_ENV'. _Standard_: ! Fortran 2003. _Class_: Elemental function --- 7710,7716 ---- `ISO_FORTRAN_ENV'. _Standard_: ! Fortran 2003 and later _Class_: Elemental function *************** _Example_: *** 7175,7181 ****  File: gfortran.info, Node: IS_IOSTAT_EOR, Next: ISATTY, Prev: IS_IOSTAT_END, Up: Intrinsic Procedures ! 6.115 `IS_IOSTAT_EOR' -- Test for end-of-record value ===================================================== _Description_: --- 7738,7744 ----  File: gfortran.info, Node: IS_IOSTAT_EOR, Next: ISATTY, Prev: IS_IOSTAT_END, Up: Intrinsic Procedures ! 7.118 `IS_IOSTAT_EOR' -- Test for end-of-record value ===================================================== _Description_: *************** _Description_: *** 7185,7191 **** `ISO_FORTRAN_ENV'. _Standard_: ! Fortran 2003. _Class_: Elemental function --- 7748,7754 ---- `ISO_FORTRAN_ENV'. _Standard_: ! Fortran 2003 and later _Class_: Elemental function *************** _Example_: *** 7213,7226 ****  File: gfortran.info, Node: ISATTY, Next: ISHFT, Prev: IS_IOSTAT_EOR, Up: Intrinsic Procedures ! 6.116 `ISATTY' -- Whether a unit is a terminal device. ====================================================== _Description_: Determine whether a unit is connected to a terminal device. _Standard_: ! GNU extension. _Class_: Function --- 7776,7789 ----  File: gfortran.info, Node: ISATTY, Next: ISHFT, Prev: IS_IOSTAT_EOR, Up: Intrinsic Procedures ! 7.119 `ISATTY' -- Whether a unit is a terminal device. ====================================================== _Description_: Determine whether a unit is connected to a terminal device. _Standard_: ! GNU extension _Class_: Function *************** _Syntax_: *** 7229,7235 **** `RESULT = ISATTY(UNIT)' _Arguments_: ! UNIT Shall be a scalar `INTEGER(*)'. _Return value_: Returns `.TRUE.' if the UNIT is connected to a terminal device, --- 7792,7798 ---- `RESULT = ISATTY(UNIT)' _Arguments_: ! UNIT Shall be a scalar `INTEGER'. _Return value_: Returns `.TRUE.' if the UNIT is connected to a terminal device, *************** _See also_: *** 7249,7255 ****  File: gfortran.info, Node: ISHFT, Next: ISHFTC, Prev: ISATTY, Up: Intrinsic Procedures ! 6.117 `ISHFT' -- Shift bits =========================== _Description_: --- 7812,7818 ----  File: gfortran.info, Node: ISHFT, Next: ISHFTC, Prev: ISATTY, Up: Intrinsic Procedures ! 7.120 `ISHFT' -- Shift bits =========================== _Description_: *************** _Description_: *** 7262,7268 **** end are lost; zeros are shifted in from the opposite end. _Standard_: ! F95 and later _Class_: Elemental function --- 7825,7831 ---- end are lost; zeros are shifted in from the opposite end. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 7271,7281 **** `RESULT = ISHFT(I, SHIFT)' _Arguments_: ! I The type shall be `INTEGER(*)'. ! SHIFT The type shall be `INTEGER(*)'. _Return value_: ! The return value is of type `INTEGER(*)' and of the same kind as I. _See also_: *note ISHFTC:: --- 7834,7844 ---- `RESULT = ISHFT(I, SHIFT)' _Arguments_: ! I The type shall be `INTEGER'. ! SHIFT The type shall be `INTEGER'. _Return value_: ! The return value is of type `INTEGER' and of the same kind as I. _See also_: *note ISHFTC:: *************** _See also_: *** 7283,7289 ****  File: gfortran.info, Node: ISHFTC, Next: ISNAN, Prev: ISHFT, Up: Intrinsic Procedures ! 6.118 `ISHFTC' -- Shift bits circularly ======================================= _Description_: --- 7846,7852 ----  File: gfortran.info, Node: ISHFTC, Next: ISNAN, Prev: ISHFT, Up: Intrinsic Procedures ! 7.121 `ISHFTC' -- Shift bits circularly ======================================= _Description_: *************** _Description_: *** 7297,7303 **** equivalent to `BIT_SIZE(I)'. _Standard_: ! F95 and later _Class_: Elemental function --- 7860,7866 ---- equivalent to `BIT_SIZE(I)'. _Standard_: ! Fortran 95 and later _Class_: Elemental function *************** _Syntax_: *** 7306,7319 **** `RESULT = ISHFTC(I, SHIFT [, SIZE])' _Arguments_: ! I The type shall be `INTEGER(*)'. ! SHIFT The type shall be `INTEGER(*)'. ! SIZE (Optional) The type shall be `INTEGER(*)'; the value must be greater than zero and less than or equal to `BIT_SIZE(I)'. _Return value_: ! The return value is of type `INTEGER(*)' and of the same kind as I. _See also_: *note ISHFT:: --- 7869,7882 ---- `RESULT = ISHFTC(I, SHIFT [, SIZE])' _Arguments_: ! I The type shall be `INTEGER'. ! SHIFT The type shall be `INTEGER'. ! SIZE (Optional) The type shall be `INTEGER'; the value must be greater than zero and less than or equal to `BIT_SIZE(I)'. _Return value_: ! The return value is of type `INTEGER' and of the same kind as I. _See also_: *note ISHFT:: *************** _See also_: *** 7321,7327 ****  File: gfortran.info, Node: ISNAN, Next: ITIME, Prev: ISHFTC, Up: Intrinsic Procedures ! 6.119 `ISNAN' -- Test for a NaN =============================== _Description_: --- 7884,7890 ----  File: gfortran.info, Node: ISNAN, Next: ITIME, Prev: ISHFTC, Up: Intrinsic Procedures ! 7.122 `ISNAN' -- Test for a NaN =============================== _Description_: *************** _Example_: *** 7356,7369 ****  File: gfortran.info, Node: ITIME, Next: KILL, Prev: ISNAN, Up: Intrinsic Procedures ! 6.120 `ITIME' -- Get current local time subroutine (hour/minutes/seconds) ========================================================================= _Description_: ! `IDATE(TARRAY)' Fills 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 TARRAY, respectively. _Standard_: GNU extension --- 7919,7932 ----  File: gfortran.info, Node: ITIME, Next: KILL, Prev: ISNAN, Up: Intrinsic Procedures ! 7.123 `ITIME' -- Get current local time subroutine (hour/minutes/seconds) ========================================================================= _Description_: ! `IDATE(VALUES)' Fills VALUES 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 VALUES, respectively. _Standard_: GNU extension *************** _Class_: *** 7372,7385 **** Subroutine _Syntax_: ! `CALL ITIME(TARRAY)' _Arguments_: ! TARRAY The type shall be `INTEGER, DIMENSION(3)' and the kind shall be the default integer kind. _Return value_: ! Does not return. _Example_: program test_itime --- 7935,7948 ---- Subroutine _Syntax_: ! `CALL ITIME(VALUES)' _Arguments_: ! VALUES The type shall be `INTEGER, DIMENSION(3)' and the kind shall be the default integer kind. _Return value_: ! Does not return anything. _Example_: program test_itime *************** _Example_: *** 7393,7399 ****  File: gfortran.info, Node: KILL, Next: KIND, Prev: ITIME, Up: Intrinsic Procedures ! 6.121 `KILL' -- Send a signal to a process ========================================== _Description_: --- 7956,7962 ----  File: gfortran.info, Node: KILL, Next: KIND, Prev: ITIME, Up: Intrinsic Procedures ! 7.124 `KILL' -- Send a signal to a process ========================================== _Description_: *************** _Class_: *** 7409,7422 **** Subroutine, function _Syntax_: ! `CALL KILL(PID, SIGNAL [, STATUS])' _Arguments_: ! PID Shall be a scalar `INTEGER', with `INTENT(IN)' ! SIGNAL Shall be a scalar `INTEGER', with `INTENT(IN)' STATUS (Optional) status flag of type `INTEGER(4)' or ! `INTEGER(8)'. Returns 0 ! on success, or a system-specific error co