diff -Nrcpad gcc-4.0.1/gcc/fortran/ChangeLog gcc-4.0.2/gcc/fortran/ChangeLog *** gcc-4.0.1/gcc/fortran/ChangeLog Thu Jul 7 18:39:00 2005 --- gcc-4.0.2/gcc/fortran/ChangeLog Wed Sep 21 03:56:59 2005 *************** *** 1,3 **** --- 1,450 ---- + 2005-09-20 Release Manager + + * GCC 4.0.2 released. + + 2005-09-13 Paul Thomas + + PR fortran/19358 + * trans-array.c (gfc_trans_dummy_array_bias): correct the typo + which uses dim[i].upper for lbound, rather than dim[i].lower. + + 2005-09-10 Volker Reichelt + + PR fortran/22502 + Backport: + + 2005-07-29 Steven Bosscher + * trans-types.h (gfc_array_range_type): Add missing GTY decl for this. + + 2005-09-09 Thomas Koenig + + * io.c (gfc_resolve_filepos): Also resolve iostat. + + 2005-09-09 Paul Thomas + + PR fortran/18878 + * module.c (find_use_name_n): Based on original + find_use_name. Either counts number of use names for a + given real name or returns use name n. + (find_use_name, number_use_names): Interfaces to the + function find_use_name_n. + (read_module): Add the logic and calls to these functions, + so that mutiple reuses of the same real name are loaded. + + 2005-09-09 Paul Thomas + + PR fortran/22304 + PR fortran/23270 + PR fortran/18870 + PR fortran/16511 + PR fortran/17917 + * gfortran.h: Move definition of BLANK_COMMON_NAME from trans- + common.c so that it is accessible to module.c. Add common_head + field to gfc_symbol structure. Add field for the equivalence + name AND new attr field, in_equivalence. + * match.c (gfc_match_common, gfc_match_equivalence): In loops + that flag common block equivalences, emit an error if the + common blocks are different, using sym->common_head as the + common block identifier. Ensure that symbols that are equivalence + associated with a common block are marked as being in_common. + * module.c (write_blank_common): New. + (write_common): Use unmangled common block name. + (load_equiv): New function ported from g95. + (read_module): Call load_equiv. + (write_equiv): New function ported from g95. Correct + string referencing for gfc functions. Give module + equivalences a unique name. + (write_module): Call write_equiv and write_blank_common. + * primary.c (match_variable) Old gfc_match_variable, made + static and third argument provided to indicate if parent + namespace to be visited or not. + (gfc_match_variable): New. Interface to match_variable. + (gfc_match_equiv_variable): New. Interface to match_variable. + * trans-common.c (finish_equivalences): Provide the call + to create_common with a gfc_common_header so that + module equivalences are made external, rather than local. + (find_equivalences): Ensure that all members in common block + equivalences are marked as used. This prevents the subsequent + call to this function from making local unions. + * trans-decl.c (gfc_generate_function_code): Move the call to + gfc_generate_contained_functions to after the call to + gfc_trans_common so the use-associated, contained common + blocks produce the correct references. + (gfc_create_module_variable): Return for equivalenced symbols + with existing backend declaration. + + 2005-09-08 Tobias Schl"uter + + PR fortran/23765 + * match.c (gfc_match_common): Remove unnecessary / wrong special + cases for end-of-statement. + + 2005-09-07 Thomas Koenig + + PR fortran/20848 + * symbol.c(check_conflict): Add conflict for parameter/save. + + 2005-09-04 Tobias Schl"uter + + PR fortran/23661 + * io.c (match_io): Correctly backup if PRINT followed by + symbol which is not a namelist. Force blank between PRINT + and namelist in free form. + + 2005-08-31 Francois-Xavier Coudert + + PR fortran/20592 + * gfortran.h (gfc_option_t): Add flag_automatic. + * invoke.texi: Document the -fno-automatic option. + * lang.opt: Add a -fautomatic option. + * options.c (gfc_init_options): Default for -fautomatic is on. + (gfc_handle_option): Add handling of -fautomatic option. + * resolve.c (gfc_resolve): When -fno-automatic is used, mark + needed variables as SAVE. + + 2005-08-25 Erik Edelmann + + PR fortran/20363 + * symbol.c (find_special): Remove. + (build_sym, add_init_expr, attr_decl1): Remove calls to + find_special in favor of calls to gfc_get_symbol. + + 2005-08-19 Steven G. Kargl + + PR fortran/23065 + * gfortran.h: Remove PATH_MAX definition. + * module.c (write_module, gfc_dump_module): Use alloca to allocate + buffers. + * scanner.c (gfc_release_include_path, form_from_filename): Ditto. + + 2004-08-16 Huang Chun + + * trans-expr.c (gfc_conv_power_op): Evaluate the expression before + expand. + + 2005-08-14 Paul Thomas + + PR fortran/21432. + * gfortran.texi: Document PRINT namelist. + + 2005-08-14 Paul Thomas + + PR fortran/21432. + * io.c (match_io): Add code to implement PRINT namelist. + + 2005-08-11 Francois-Xavier Coudert + Steven Bosscher + + PR libfortran/20006 + * gfortran.h: Add is_main_program member to symbol_attribute. + * trans-decl: Add a gfor_fndecl_set_std tree. + (gfc_build_builtin_function_decls): Create it. + (gfc_generate_function_code): Add this call at the beginning of + the main program. + * trans.c (gfc_generate_code): Move main_program and attr. + * trans.h: Add declaration for gfor_fndecl_set_std. + + 2005-08-10 Thomas Koenig + + PR libfortran/22143 + gfortran.h: Declare new function gfc_resolve_dim_arg. + resolve.c: New function gfc_resolve_dim_arg. + iresolve.c (gfc_resolve_all): Use gfc_resolve_dim_arg. + (gfc_resolve_any): Likewise. + (gfc_resolve_count): Likewise. + (gfc_resolve_cshift): Likewise. If the kind of shift is less + gfc_default_integer_kind, convert it to default integer type. + (gfc_resolve_eoshift): Likewise. + (gfc_resolve_maxloc): Use gfc_resolve_dim_arg. + (gfc_resolve_maxval): Likewise. + (gfc_resolve_minloc): Likewise. + (gfc_resolve_minval): Likewise. + (gfc_resolve_product): Likewise. + (gfc_resolve_spread): Likewise. + (gfc_resolve_sum): Likewise. + + 2005-08-07 Francois-Xavier Coudert + + * check.c (gfc_check_ttynam_sub, gfc_check_isatty): Add check + functions for new intrinsics TTYNAM and ISATTY. + * intrinsic.c (add_functions, add_subroutines): Add new + intrinsics. + * intrinsic.h: Add prototypes for new check and resolve + functions. + * iresolve.c (gfc_resolve_isatty, gfc_resolve_ttynam_sub): New + resolve functions for intrinsics TTYNAM and ISATTY. + * gfortran.h (gfc_generic_isym_id): Add symbol for ISATTY. + * trans-intrinsic.c: Add case for GFC_ISYM_ISATTY. + + 2005-08-09 Jakub Jelinek + + * scanner.c (preprocessor_line): Don't write beyond the end of flag + buffer. + + 2005-08-06 Francois-Xavier Coudert + + * primary.c (match_hollerith_constant): Fix typo. + + 2005-08-06 Jakub Jelinek + + PR fortran/18833 + PR fortran/20850 + * primary.c (match_varspec): If equiv_flag, don't look at sym's + attributes, call gfc_match_array_ref up to twice and don't do any + substring or component processing. + * resolve.c (resolve_equivalence): Transform REF_ARRAY into + REF_SUBSTRING or nothing if needed. Check that substrings + don't have zero length. + + 2005-08-05 Tobias Schlueter + Paul Thomas + + PR fortran/22010 + Port from g95. + * module.c (mio_namelist): New function. Correct to set + namelist_tail and to give error on renaming namelist by use + association. + (mio_symbol): Call mio_namelist. + + 2005-08-04 Paul Brook + + * trans-expr.c (gfc_conv_expr, gfc_conv_expr_type): Update comments. + (gfc_conv_expr_lhs): Fix assertion. + (gfc_conv_expr_val): Merge post block. Set se.expr to new value. + * trans.h: Move and update comments. + + 2005-07-31 Jerry DeLisle + + * intrinsic.texi: Backport from 4.1 branch. + + 2005-07-27 Volker Reichelt + + PR fortran/22503 + * resolve.c (resolve_operator): Improve diagnostic for comparison + of logicals with invalid operator. + + 2005-07-25 Jakub Jelinek + + PR fortran/20063 + * data.c (gfc_assign_data_value_range): Call + create_character_initializer if last_ts is a character type. + + 2005-07-22 Paul Thomas + + PR fortran/16940 + * resolve.c (resolve_symbol): A symbol with FL_UNKNOWN + is matched against interfaces in parent namespaces. If there + the symtree is set to point to the interface. + + 2005-07-19 Francois-Xavier Coudert + + PR fortran/20842 + * io.c (match_dt_element): Do not allow END tag in PRINT or + WRITE statement. + + 2005-07-16 Andrew Pinski + + PR fortran/13257 + * io.c (check_format): Allow an optional comma + between descriptors. + + 2005-07-15 Paul Brook + + Backport form mainline. + 2005-06-22 Paul Brook + PR fortran/21034 + * symbol.c (gfc_is_var_automatic): New function. + (save_symbol): Use it. + + 2005-07-14 Jakub Jelinek + + * gfortran.h (MAX_ERROR_MESSAGE): Remove. + (gfc_error_buf): Add allocated and index fields. Change message + field from array to a pointer. + * error.c (use_warning_buffer, error_ptr, warning_ptr): Remove. + (cur_error_buffer): New variable. + (error_char): Use cur_error_buffer->{message,index} instead of + {warning,error}_{buffer.message,ptr}. Reallocate message buffer + if too small. + (gfc_warning, gfc_notify_std, gfc_error, gfc_error_now): Setup + cur_error_buffer and its index rather than {warning,error}_ptr + and use_warning_buffer. + (gfc_warning_check, gfc_error_check): Don't print anything if + message is NULL. + (gfc_push_error): Allocate saved message with xstrdup. + (gfc_pop_error): Free saved message with gfc_free. + (gfc_free_error): New function. + * primary.c (match_complex_constant): Call gfc_free_error if + gfc_pop_error will not be called. + * match.c (gfc_match_st_function): Likewise. + + PR fortran/22417 + * scanner.c (preprocessor_line): Don't treat flag 3 as the start of a new + file. Fix file left but not entered warning. + + 2005-07-14 Feng Wang + Steven G. Kargl + + * array.c (resolve_character_array_constructor): Allocate gfc_charlen + for the array and attach to namespace list for automatic deallocation. + + 2005-07-12 Feng Wang + + Backport from the mainline: + 2005-03-05 Tobias Schl"uter + * trans-const.c (gfc_conv_constant_to_tree): Use correct tree + type for COMPLEX constants. + + 2005-07-07 Feng Wang + PR fortran/16531 + PR fortran/15966 + PR fortran/18781 + * arith.c (gfc_hollerith2int, gfc_hollerith2real, + gfc_hollerith2complex, gfc_hollerith2character, gfc_hollerith2logical): + New functions. + (eval_intrinsic): Don't evaluate if Hollerith constant arguments exist. + * arith.h (gfc_hollerith2int, gfc_hollerith2real, + gfc_hollerith2complex, gfc_hollerith2character, gfc_hollerith2logical): + Add prototypes. + * expr.c (free_expr0): Free memery allocated for Hollerith constant. + (gfc_copy_expr): Allocate and copy string if Expr is from Hollerith. + (gfc_check_assign): Enable conversion from Hollerith to other. + * gfortran.h (bt): Add BT_HOLLERITH. + (gfc_expr): Add from_H flag. + * intrinsic.c (gfc_type_letter): Return 'h' for BT_HOLLERITH. + (add_conversions): Add conversions from Hollerith constant to other. + (do_simplify): Don't simplify if Hollerith constant arguments exist. + * io.c (resolve_tag): Enable array in FORMAT tag under GFC_STD_GNU. + * misc.c (gfc_basetype_name): Return "HOLLERITH" for BT_HOLLERITH. + (gfc_type_name): Print "HOLLERITH" for BT_HOLLERITH. + * primary.c (match_hollerith_constant): New function. + (gfc_match_literal_constant): Add match Hollerith before Integer. + * simplify.c (gfc_convert_constant): Add conversion from Hollerith + to other. + * trans-const.c (gfc_conv_constant_to_tree): Use VIEW_CONVERT_EXPR to + convert Hollerith constant to tree. + * trans-io.c (gfc_convert_array_to_string): Get array's address and + length to set string expr. + (set_string): Deal with array assigned Hollerith constant and character + array. + * gfortran.texi: Document Hollerith constants as extention support. + + 2005-07-11 Feng Wang + + * match.c (gfc_match_label): Remove unused variable. + + Backport from the mainline: + 2005-06-01 Roger Sayle + + * intrinsic.c (add_conv): No longer take a "simplify" argument as + its always gfc_convert_constant, instead take a "standard" argument. + (add_conversions): Change all existing calls of add_conv to pass + GFC_STD_F77 as appropriate. Additionally, if we're allowing GNU + extensions support integer-logical and logical-integer conversions. + (gfc_convert_type_warn): Warn about use the use of these conversions + as a extension when appropriate, i.e. with -pedantic. + * simplify.c (gfc_convert_constant): Add support for integer to + logical and logical to integer conversions, using gfc_int2log and + gfc_log2int. + * arith.c (gfc_log2int, gfc_int2log): New functions. + * arith.h (gfc_log2int, gfc_int2log): Prototype here. + * gfortran.texi: Document this new GNU extension. + + 2005-05-30 Roger Sayle + * gfortran.h (GFC_STD_LEGACY): New "standard" macro. Reindent. + * options.c (gfc_init_options): By default, allow legacy extensions + but warn about them. + (gfc_post_options): Make -pedantic warn about legacy extensions + even with -std=legacy. + (gfc_handle_option): Make -std=gnu follow the default behaviour + of warning about legacy extensions, but allowing them. Make the + new -std=legacy accept everything and warn about nothing. + * lang.opt (std=legacy): New F95 command line option. + * invoke.texi: Document both -std=f2003 and -std=legacy. + * gfortran.texi: Explain the two types of extensions and document + how they are affected by the various -std= command line options. + + 2005-07-11 Jakub Jelinek + + * trans-stmt.c (gfc_trans_forall_loop): Clear maskindex before + the outermost loop. + (gfc_trans_assign_need_temp, gfc_trans_pointer_assign_need_temp, + gfc_trans_forall_1, gfc_evaluate_where_mask, gfc_trans_where_2): + Don't clear maskindexes here. + + 2005-07-10 Feng Wang + + Backport from the mainline: + 2005-07-07 Feng Wang + PR fortran/22327 + * trans-array.c (gfc_trans_array_constructor_value): Fix index of data. + + 2005-06-24 Feng Wang + * simplify.c (gfc_simplify_modulo): Don't clear before get result. + + 2005-07-09 Jakub Jelinek + + Backport from the mainline: + 2005-07-08 Jakub Jelinek + * primary.c (gfc_match_rvalue): Handle ENTRY the same way + as FUNCTION. + + 2005-07-07 Jakub Jelinek + * scanner.c (load_line): Add pbuflen argument, don't make + buflen static. If maxlen == 0 or preprocessor_flag, + don't truncate at buflen, but at maxlen. In xrealloc add + 1 byte at the end for the terminating '\0'. Don't fill + with spaces up to buflen, but gfc_option.fixed_line_length. + (load_file): Adjust load_line caller. Add line_len variable. + + * scanner.c (preprocessor_line): Only set current_file->line when errors + have not been encountered. Warn and don't crash if a file leave + preprocessor line has no corresponding entering line. Formatting. + + 2005-07-07 Jakub Jelinek + * decl.c (gfc_match_entry): Allow ENTRY without parentheses + even in FUNCTIONs. + + 2005-06-25 Jakub Jelinek + * trans-stmt.c (gfc_trans_forall_1): Prefer to use smaller logical + type than boolean_type_node. + + 2005-06-13 Jakub Jelinek + * trans-expr.c (gfc_conv_function_call): Return int instead of + void. Use a local variable for has_alternate_specifier and + return it. Avoid modification of function type's return value + in place, since it may be shared. + * trans.h (has_alternate_specifier): Remove. + (gfc_conv_function_call): Change return type. + * trans-stmt.c (has_alternate_specifier): Remove. + (gfc_trans_call): Add a local has_alternate_specifier variable, + set it from gfc_conv_function_call return value. + + 2005-07-08 Steven G. Kargl + + Backport from the mainline: + PR fortran/21257 + (port from g95) + * match.c (gfc_match_label): Detect duplicate labels. + * gfortran.dg/duplicate_labels.f90: New test. + + PR fortran/19926 + * primary.c (gfc_match_rvalue): expr_type can be EXPR_CONSTANT + for an array; check that sym->as is NULL. + * gfortran.dg/pr19926.f90: New test. + + PR fortran/17792 + PR fortran/21375 + * trans-array.c (gfc_array_deallocate): pstat is new argument + (gfc_array_allocate): update gfc_array_deallocate() call. + (gfc_trans_deferred_array): ditto. + * trans-array.h: update gfc_array_deallocate() prototype. + * trans-decl.c (gfc_build_builtin_function_decls): update declaration + * trans-stmt.c (gfc_trans_deallocate): Implement STAT= feature. + + * intrinsic.c (gfc_intrinsic_func_interface): Enable errors for generic + functions whose simplification routine return FAILURE. + 2005-07-07 Release Manager * GCC 4.0.1 released. diff -Nrcpad gcc-4.0.1/gcc/fortran/arith.c gcc-4.0.2/gcc/fortran/arith.c *** gcc-4.0.1/gcc/fortran/arith.c Sat Mar 19 19:28:44 2005 --- gcc-4.0.2/gcc/fortran/arith.c Tue Jul 12 01:50:47 2005 *************** eval_intrinsic (gfc_intrinsic_op operato *** 1624,1640 **** if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER) goto runtime; ! if (op1->expr_type != EXPR_CONSTANT ! && (op1->expr_type != EXPR_ARRAY ! || !gfc_is_constant_expr (op1) ! || !gfc_expanded_ac (op1))) goto runtime; if (op2 != NULL ! && op2->expr_type != EXPR_CONSTANT ! && (op2->expr_type != EXPR_ARRAY ! || !gfc_is_constant_expr (op2) ! || !gfc_expanded_ac (op2))) goto runtime; if (unary) --- 1624,1642 ---- if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER) goto runtime; ! if (op1->from_H ! || (op1->expr_type != EXPR_CONSTANT ! && (op1->expr_type != EXPR_ARRAY ! || !gfc_is_constant_expr (op1) ! || !gfc_expanded_ac (op1)))) goto runtime; if (op2 != NULL ! && (op2->from_H ! || (op2->expr_type != EXPR_CONSTANT ! && (op2->expr_type != EXPR_ARRAY ! || !gfc_is_constant_expr (op2) ! || !gfc_expanded_ac (op2))))) goto runtime; if (unary) *************** gfc_log2log (gfc_expr * src, int kind) *** 2233,2235 **** --- 2235,2416 ---- return result; } + + /* Convert logical to integer. */ + + gfc_expr * + gfc_log2int (gfc_expr *src, int kind) + { + gfc_expr *result; + result = gfc_constant_result (BT_INTEGER, kind, &src->where); + mpz_set_si (result->value.integer, src->value.logical); + return result; + } + + /* Convert integer to logical. */ + + gfc_expr * + gfc_int2log (gfc_expr *src, int kind) + { + gfc_expr *result; + result = gfc_constant_result (BT_LOGICAL, kind, &src->where); + result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0); + return result; + } + + /* Convert Hollerith to integer. The constant will be padded or truncated. */ + + gfc_expr * + gfc_hollerith2int (gfc_expr * src, int kind) + { + gfc_expr *result; + int len; + + len = src->value.character.length; + + result = gfc_get_expr (); + result->expr_type = EXPR_CONSTANT; + result->ts.type = BT_INTEGER; + result->ts.kind = kind; + result->where = src->where; + result->from_H = 1; + + if (len > kind) + { + gfc_warning ("The Hollerith constant at %L is too long to convert to %s", + &src->where, gfc_typename(&result->ts)); + } + result->value.character.string = gfc_getmem (kind + 1); + memcpy (result->value.character.string, src->value.character.string, + MIN (kind, len)); + + if (len < kind) + memset (&result->value.character.string[len], ' ', kind - len); + + result->value.character.string[kind] = '\0'; /* For debugger */ + result->value.character.length = kind; + + return result; + } + + /* Convert Hollerith to real. The constant will be padded or truncated. */ + + gfc_expr * + gfc_hollerith2real (gfc_expr * src, int kind) + { + gfc_expr *result; + int len; + + len = src->value.character.length; + + result = gfc_get_expr (); + result->expr_type = EXPR_CONSTANT; + result->ts.type = BT_REAL; + result->ts.kind = kind; + result->where = src->where; + result->from_H = 1; + + if (len > kind) + { + gfc_warning ("The Hollerith constant at %L is too long to convert to %s", + &src->where, gfc_typename(&result->ts)); + } + result->value.character.string = gfc_getmem (kind + 1); + memcpy (result->value.character.string, src->value.character.string, + MIN (kind, len)); + + if (len < kind) + memset (&result->value.character.string[len], ' ', kind - len); + + result->value.character.string[kind] = '\0'; /* For debugger */ + result->value.character.length = kind; + + return result; + } + + /* Convert Hollerith to complex. The constant will be padded or truncated. */ + + gfc_expr * + gfc_hollerith2complex (gfc_expr * src, int kind) + { + gfc_expr *result; + int len; + + len = src->value.character.length; + + result = gfc_get_expr (); + result->expr_type = EXPR_CONSTANT; + result->ts.type = BT_COMPLEX; + result->ts.kind = kind; + result->where = src->where; + result->from_H = 1; + + kind = kind * 2; + + if (len > kind) + { + gfc_warning ("The Hollerith constant at %L is too long to convert to %s", + &src->where, gfc_typename(&result->ts)); + } + result->value.character.string = gfc_getmem (kind + 1); + memcpy (result->value.character.string, src->value.character.string, + MIN (kind, len)); + + if (len < kind) + memset (&result->value.character.string[len], ' ', kind - len); + + result->value.character.string[kind] = '\0'; /* For debugger */ + result->value.character.length = kind; + + return result; + } + + /* Convert Hollerith to character. */ + + gfc_expr * + gfc_hollerith2character (gfc_expr * src, int kind) + { + gfc_expr *result; + + result = gfc_copy_expr (src); + result->ts.type = BT_CHARACTER; + result->ts.kind = kind; + result->from_H = 1; + + return result; + } + + /* Convert Hollerith to logical. The constant will be padded or truncated. */ + + gfc_expr * + gfc_hollerith2logical (gfc_expr * src, int kind) + { + gfc_expr *result; + int len; + + len = src->value.character.length; + + result = gfc_get_expr (); + result->expr_type = EXPR_CONSTANT; + result->ts.type = BT_LOGICAL; + result->ts.kind = kind; + result->where = src->where; + result->from_H = 1; + + if (len > kind) + { + gfc_warning ("The Hollerith constant at %L is too long to convert to %s", + &src->where, gfc_typename(&result->ts)); + } + result->value.character.string = gfc_getmem (kind + 1); + memcpy (result->value.character.string, src->value.character.string, + MIN (kind, len)); + + if (len < kind) + memset (&result->value.character.string[len], ' ', kind - len); + + result->value.character.string[kind] = '\0'; /* For debugger */ + result->value.character.length = kind; + + return result; + } diff -Nrcpad gcc-4.0.1/gcc/fortran/arith.h gcc-4.0.2/gcc/fortran/arith.h *** gcc-4.0.1/gcc/fortran/arith.h Fri Aug 6 20:36:04 2004 --- gcc-4.0.2/gcc/fortran/arith.h Tue Jul 12 01:50:47 2005 *************** gfc_expr *gfc_complex2int (gfc_expr *, i *** 80,85 **** --- 80,92 ---- gfc_expr *gfc_complex2real (gfc_expr *, int); gfc_expr *gfc_complex2complex (gfc_expr *, int); gfc_expr *gfc_log2log (gfc_expr *, int); + gfc_expr *gfc_log2int (gfc_expr *, int); + gfc_expr *gfc_int2log (gfc_expr *, int); + gfc_expr *gfc_hollerith2int (gfc_expr *, int); + gfc_expr *gfc_hollerith2real (gfc_expr *, int); + gfc_expr *gfc_hollerith2complex (gfc_expr *, int); + gfc_expr *gfc_hollerith2character (gfc_expr *, int); + gfc_expr *gfc_hollerith2logical (gfc_expr *, int); #endif /* GFC_ARITH_H */ diff -Nrcpad gcc-4.0.1/gcc/fortran/array.c gcc-4.0.2/gcc/fortran/array.c *** gcc-4.0.1/gcc/fortran/array.c Sat Jun 4 17:59:59 2005 --- gcc-4.0.2/gcc/fortran/array.c Thu Jul 14 01:59:43 2005 *************** resolve_character_array_constructor (gfc *** 1516,1522 **** max_length = -1; ! if (expr->ts.cl == NULL || expr->ts.cl->length == NULL) { /* Find the maximum length of the elements. Do nothing for variable array constructor. */ --- 1516,1529 ---- max_length = -1; ! if (expr->ts.cl == NULL) ! { ! expr->ts.cl = gfc_get_charlen (); ! expr->ts.cl->next = gfc_current_ns->cl_list; ! gfc_current_ns->cl_list = expr->ts.cl; ! } ! ! if (expr->ts.cl->length == NULL) { /* Find the maximum length of the elements. Do nothing for variable array constructor. */ *************** resolve_character_array_constructor (gfc *** 1529,1536 **** if (max_length != -1) { /* Update the character length of the array constructor. */ - if (expr->ts.cl == NULL) - expr->ts.cl = gfc_get_charlen (); expr->ts.cl->length = gfc_int_expr (max_length); /* Update the element constructors. */ for (p = expr->value.constructor; p; p = p->next) --- 1536,1541 ---- diff -Nrcpad gcc-4.0.1/gcc/fortran/check.c gcc-4.0.2/gcc/fortran/check.c *** gcc-4.0.1/gcc/fortran/check.c Mon Apr 25 00:09:13 2005 --- gcc-4.0.2/gcc/fortran/check.c Tue Aug 9 17:44:02 2005 *************** gfc_check_hostnm_sub (gfc_expr * name, g *** 2574,2579 **** --- 2574,2611 ---- try + gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name) + { + if (scalar_check (unit, 0) == FAILURE) + return FAILURE; + + if (type_check (unit, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (name, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; + } + + + try + gfc_check_isatty (gfc_expr * unit) + { + if (unit == NULL) + return FAILURE; + + if (type_check (unit, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (unit, 0) == FAILURE) + return FAILURE; + + return SUCCESS; + } + + + try gfc_check_perror (gfc_expr * string) { if (type_check (string, 0, BT_CHARACTER) == FAILURE) diff -Nrcpad gcc-4.0.1/gcc/fortran/data.c gcc-4.0.2/gcc/fortran/data.c *** gcc-4.0.1/gcc/fortran/data.c Sun Jan 23 14:36:24 2005 --- gcc-4.0.2/gcc/fortran/data.c Mon Jul 25 08:46:58 2005 *************** gfc_assign_data_value_range (gfc_expr * *** 459,470 **** last_con = con; } ! /* We should never be overwriting an existing initializer. */ ! gcc_assert (!init); ! expr = gfc_copy_expr (rvalue); ! if (!gfc_compare_types (&lvalue->ts, &expr->ts)) ! gfc_convert_type (expr, &lvalue->ts, 0); if (last_con == NULL) symbol->value = expr; --- 459,475 ---- last_con = con; } ! if (last_ts->type == BT_CHARACTER) ! expr = create_character_intializer (init, last_ts, NULL, rvalue); ! else ! { ! /* We should never be overwriting an existing initializer. */ ! gcc_assert (!init); ! expr = gfc_copy_expr (rvalue); ! if (!gfc_compare_types (&lvalue->ts, &expr->ts)) ! gfc_convert_type (expr, &lvalue->ts, 0); ! } if (last_con == NULL) symbol->value = expr; diff -Nrcpad gcc-4.0.1/gcc/fortran/decl.c gcc-4.0.2/gcc/fortran/decl.c *** gcc-4.0.1/gcc/fortran/decl.c Fri Apr 29 16:01:11 2005 --- gcc-4.0.2/gcc/fortran/decl.c Thu Aug 25 12:25:21 2005 *************** syntax: *** 530,558 **** } ! /* Special subroutine for finding a symbol. If we're compiling a ! function or subroutine and the parent compilation unit is an ! interface, then check to see if the name we've been given is the ! name of the interface (located in another namespace). If so, ! return that symbol. If not, use gfc_get_symbol(). */ static int find_special (const char *name, gfc_symbol ** result) { gfc_state_data *s; if (gfc_current_state () != COMP_SUBROUTINE && gfc_current_state () != COMP_FUNCTION) ! goto normal; s = gfc_state_stack->previous; if (s == NULL) ! goto normal; if (s->state != COMP_INTERFACE) ! goto normal; if (s->sym == NULL) ! goto normal; /* Nameless interface */ if (strcmp (name, s->sym->name) == 0) { --- 530,563 ---- } ! /* Special subroutine for finding a symbol. Check if the name is found ! in the current name space. If not, and we're compiling a function or ! subroutine and the parent compilation unit is an interface, then check ! to see if the name we've been given is the name of the interface ! (located in another namespace). */ static int find_special (const char *name, gfc_symbol ** result) { gfc_state_data *s; + int i; + i = gfc_get_symbol (name, NULL, result); + if (i==0) + goto end; + if (gfc_current_state () != COMP_SUBROUTINE && gfc_current_state () != COMP_FUNCTION) ! goto end; s = gfc_state_stack->previous; if (s == NULL) ! goto end; if (s->state != COMP_INTERFACE) ! goto end; if (s->sym == NULL) ! goto end; /* Nameless interface */ if (strcmp (name, s->sym->name) == 0) { *************** find_special (const char *name, gfc_symb *** 560,567 **** return 0; } ! normal: ! return gfc_get_symbol (name, NULL, result); } --- 565,572 ---- return 0; } ! end: ! return i; } *************** build_sym (const char *name, gfc_charlen *** 616,622 **** symbol_attribute attr; gfc_symbol *sym; ! if (find_special (name, &sym)) return FAILURE; /* Start updating the symbol table. Add basic type attribute --- 621,628 ---- symbol_attribute attr; gfc_symbol *sym; ! /* if (find_special (name, &sym)) */ ! if (gfc_get_symbol (name, NULL, &sym)) return FAILURE; /* Start updating the symbol table. Add basic type attribute *************** gfc_match_entry (void) *** 2395,2401 **** else { /* An entry in a function. */ ! m = gfc_match_formal_arglist (entry, 0, 0); if (m != MATCH_YES) return MATCH_ERROR; --- 2401,2407 ---- else { /* An entry in a function. */ ! m = gfc_match_formal_arglist (entry, 0, 1); if (m != MATCH_YES) return MATCH_ERROR; diff -Nrcpad gcc-4.0.1/gcc/fortran/error.c gcc-4.0.2/gcc/fortran/error.c *** gcc-4.0.1/gcc/fortran/error.c Sun Jan 16 17:53:26 2005 --- gcc-4.0.2/gcc/fortran/error.c Thu Jul 14 10:19:28 2005 *************** Software Foundation, 59 Temple Place - S *** 33,44 **** int gfc_suppress_error = 0; ! static int terminal_width, buffer_flag, errors, ! use_warning_buffer, warnings; ! ! static char *error_ptr, *warning_ptr; ! static gfc_error_buf error_buffer, warning_buffer; /* Per-file error initialization. */ --- 33,41 ---- 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. */ *************** error_char (char c) *** 70,87 **** { if (buffer_flag) { ! if (use_warning_buffer) ! { ! *warning_ptr++ = c; ! if (warning_ptr - warning_buffer.message >= MAX_ERROR_MESSAGE) ! gfc_internal_error ("error_char(): Warning buffer overflow"); ! } ! else { ! *error_ptr++ = c; ! if (error_ptr - error_buffer.message >= MAX_ERROR_MESSAGE) ! gfc_internal_error ("error_char(): Error buffer overflow"); } } else { --- 67,82 ---- { if (buffer_flag) { ! if (cur_error_buffer->index >= cur_error_buffer->allocated) { ! 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; } else { *************** error_char (char c) *** 89,99 **** { /* We build up complete lines before handing things over to the library in order to speed up error printing. */ ! static char line[MAX_ERROR_MESSAGE + 1]; ! static int index = 0; line[index++] = c; ! if (c == '\n' || index == MAX_ERROR_MESSAGE) { line[index] = '\0'; fputs (line, stderr); --- 84,99 ---- { /* We build up complete lines before handing things over to the library in order to speed up error printing. */ ! static char *line; ! static size_t allocated = 0, index = 0; + if (index + 1 >= allocated) + { + allocated = allocated ? allocated * 2 : 1000; + line = xrealloc (line, allocated); + } line[index++] = c; ! if (c == '\n') { line[index] = '\0'; fputs (line, stderr); *************** gfc_warning (const char *format, ...) *** 470,477 **** return; warning_buffer.flag = 1; ! warning_ptr = warning_buffer.message; ! use_warning_buffer = 1; va_start (argp, format); if (buffer_flag == 0) --- 470,477 ---- return; warning_buffer.flag = 1; ! warning_buffer.index = 0; ! cur_error_buffer = &warning_buffer; va_start (argp, format); if (buffer_flag == 0) *************** gfc_notify_std (int std, const char *for *** 503,520 **** if (gfc_suppress_error) return warning ? SUCCESS : FAILURE; ! if (warning) ! { ! warning_buffer.flag = 1; ! warning_ptr = warning_buffer.message; ! use_warning_buffer = 1; ! } ! else ! { ! error_buffer.flag = 1; ! error_ptr = error_buffer.message; ! use_warning_buffer = 0; ! } if (buffer_flag == 0) { --- 503,511 ---- if (gfc_suppress_error) return warning ? SUCCESS : FAILURE; ! cur_error_buffer = warning ? &warning_buffer : &error_buffer; ! cur_error_buffer->flag = 1; ! cur_error_buffer->index = 0; if (buffer_flag == 0) { *************** gfc_warning_check (void) *** 577,583 **** if (warning_buffer.flag) { warnings++; ! fputs (warning_buffer.message, stderr); warning_buffer.flag = 0; } } --- 568,575 ---- if (warning_buffer.flag) { warnings++; ! if (warning_buffer.message != NULL) ! fputs (warning_buffer.message, stderr); warning_buffer.flag = 0; } } *************** gfc_error (const char *format, ...) *** 594,601 **** return; error_buffer.flag = 1; ! error_ptr = error_buffer.message; ! use_warning_buffer = 0; va_start (argp, format); if (buffer_flag == 0) --- 586,593 ---- return; error_buffer.flag = 1; ! error_buffer.index = 0; ! cur_error_buffer = &error_buffer; va_start (argp, format); if (buffer_flag == 0) *************** gfc_error_now (const char *format, ...) *** 616,622 **** int i; error_buffer.flag = 1; ! error_ptr = error_buffer.message; i = buffer_flag; buffer_flag = 0; --- 608,615 ---- int i; error_buffer.flag = 1; ! error_buffer.index = 0; ! cur_error_buffer = &error_buffer; i = buffer_flag; buffer_flag = 0; *************** gfc_error_check (void) *** 691,697 **** if (error_buffer.flag) { errors++; ! fputs (error_buffer.message, stderr); error_buffer.flag = 0; } --- 684,691 ---- if (error_buffer.flag) { errors++; ! if (error_buffer.message != NULL) ! fputs (error_buffer.message, stderr); error_buffer.flag = 0; } *************** gfc_push_error (gfc_error_buf * err) *** 706,712 **** { err->flag = error_buffer.flag; if (error_buffer.flag) ! strcpy (err->message, error_buffer.message); error_buffer.flag = 0; } --- 700,706 ---- { err->flag = error_buffer.flag; if (error_buffer.flag) ! err->message = xstrdup (error_buffer.message); error_buffer.flag = 0; } *************** gfc_pop_error (gfc_error_buf * err) *** 719,725 **** { error_buffer.flag = err->flag; if (error_buffer.flag) ! strcpy (error_buffer.message, err->message); } --- 713,734 ---- { error_buffer.flag = err->flag; if (error_buffer.flag) ! { ! size_t len = strlen (err->message) + 1; ! gcc_assert (len <= error_buffer.allocated); ! memcpy (error_buffer.message, err->message, len); ! gfc_free (err->message); ! } ! } ! ! ! /* Free a pushed error state, but keep the current error state. */ ! ! void ! gfc_free_error (gfc_error_buf * err) ! { ! if (err->flag) ! gfc_free (err->message); } diff -Nrcpad gcc-4.0.1/gcc/fortran/expr.c gcc-4.0.2/gcc/fortran/expr.c *** gcc-4.0.1/gcc/fortran/expr.c Wed Apr 6 18:07:50 2005 --- gcc-4.0.2/gcc/fortran/expr.c Tue Jul 12 01:50:47 2005 *************** free_expr0 (gfc_expr * e) *** 141,146 **** --- 141,152 ---- switch (e->expr_type) { case EXPR_CONSTANT: + if (e->from_H) + { + gfc_free (e->value.character.string); + break; + } + switch (e->ts.type) { case BT_INTEGER: *************** free_expr0 (gfc_expr * e) *** 152,157 **** --- 158,164 ---- break; case BT_CHARACTER: + case BT_HOLLERITH: gfc_free (e->value.character.string); break; *************** gfc_copy_expr (gfc_expr * p) *** 393,398 **** --- 400,414 ---- break; case EXPR_CONSTANT: + if (p->from_H) + { + 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; + } switch (q->ts.type) { case BT_INTEGER: *************** gfc_copy_expr (gfc_expr * p) *** 414,419 **** --- 430,436 ---- break; case BT_CHARACTER: + case BT_HOLLERITH: s = gfc_getmem (p->value.character.length + 1); q->value.character.string = s; *************** gfc_check_assign (gfc_expr * lvalue, gfc *** 1813,1819 **** if (!conform) { ! if (gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) return SUCCESS; if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) --- 1830,1839 ---- if (!conform) { ! /* Numeric can be converted to any other numeric. And Hollerith can be ! converted to any other type. */ ! if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) ! || rvalue->ts.type == BT_HOLLERITH) return SUCCESS; if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) diff -Nrcpad gcc-4.0.1/gcc/fortran/gfortran.h gcc-4.0.2/gcc/fortran/gfortran.h *** gcc-4.0.1/gcc/fortran/gfortran.h Mon Jun 20 20:16:55 2005 --- gcc-4.0.2/gcc/fortran/gfortran.h Fri Sep 9 09:05:52 2005 *************** char *alloca (); *** 58,64 **** #define GFC_MAX_LINE 132 /* Characters beyond this are not seen. */ #define GFC_MAX_DIMENSIONS 7 /* Maximum dimensions in an array. */ #define GFC_LETTERS 26 /* Number of letters in the alphabet. */ - #define MAX_ERROR_MESSAGE 1000 /* Maximum length of an error message. */ #define free(x) Use_gfc_free_instead_of_free() #define gfc_is_whitespace(c) ((c==' ') || (c=='\t')) --- 58,63 ---- *************** char *alloca (); *** 78,83 **** --- 77,84 ---- #define PREFIX(x) "_gfortran_" x #define PREFIX_LEN 10 + #define BLANK_COMMON_NAME "__BLNK__" + /* Macro to initialize an mstring structure. */ #define minit(s, t) { s, NULL, t } *************** mstring; *** 92,104 **** /* Flags to specify which standard/extension contains a feature. */ ! #define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */ ! #define GFC_STD_F2003 (1<<4) /* New in F2003. */ /* Note that no features were obsoleted nor deleted in F2003. */ ! #define GFC_STD_F95 (1<<3) /* New in F95. */ ! #define GFC_STD_F95_DEL (1<<2) /* Deleted in F95. */ ! #define GFC_STD_F95_OBS (1<<1) /* Obsoleted in F95. */ ! #define GFC_STD_F77 (1<<0) /* Up to and including F77. */ /*************************** Enums *****************************/ --- 93,106 ---- /* Flags to specify which standard/extension contains a feature. */ ! #define GFC_STD_LEGACY (1<<6) /* Backward compatibility. */ ! #define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */ ! #define GFC_STD_F2003 (1<<4) /* New in F2003. */ /* Note that no features were obsoleted nor deleted in F2003. */ ! #define GFC_STD_F95 (1<<3) /* New in F95. */ ! #define GFC_STD_F95_DEL (1<<2) /* Deleted in F95. */ ! #define GFC_STD_F95_OBS (1<<1) /* Obsoleted in F95. */ ! #define GFC_STD_F77 (1<<0) /* Up to and including F77. */ /*************************** Enums *****************************/ *************** gfc_source_form; *** 126,132 **** typedef enum { BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX, ! BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE } bt; --- 128,134 ---- typedef enum { BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX, ! BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH } bt; *************** enum gfc_generic_isym_id *** 332,337 **** --- 334,340 ---- GFC_ISYM_INT, GFC_ISYM_IOR, GFC_ISYM_IRAND, + GFC_ISYM_ISATTY, GFC_ISYM_ISHFT, GFC_ISYM_ISHFTC, GFC_ISYM_KILL, *************** typedef struct *** 415,421 **** unsigned data:1, /* Symbol is named in a DATA statement. */ use_assoc:1; /* Symbol has been use-associated. */ ! unsigned in_namelist:1, in_common:1; unsigned function:1, subroutine:1, generic:1; unsigned implicit_type:1; /* Type defined via implicit rules. */ unsigned untyped:1; /* No implicit type could be found. */ --- 418,424 ---- unsigned data:1, /* Symbol is named in a DATA statement. */ use_assoc:1; /* Symbol has been use-associated. */ ! unsigned in_namelist:1, in_common:1, in_equivalence:1; unsigned function:1, subroutine:1, generic:1; unsigned implicit_type:1; /* Type defined via implicit rules. */ unsigned untyped:1; /* No implicit type could be found. */ *************** typedef struct *** 428,436 **** --- 431,441 ---- don't have any code associated, and the backend will turn them into thunks to the master function. */ unsigned entry:1; + /* Set if this is the master function for a procedure with multiple entry points. */ unsigned entry_master:1; + /* Set if this is the master function for a function with multiple entry points where characteristics of the entry points differ. */ unsigned mixed_entry_master:1; *************** typedef struct *** 442,447 **** --- 447,457 ---- modification of type or type parameters is permitted. */ unsigned referenced:1; + /* Set if the is the symbol for the main program. This is the least + cumbersome way to communicate this function property without + strcmp'ing with __MAIN everywhere. */ + unsigned is_main_program:1; + /* Mutually exclusive multibit attributes. */ gfc_access access:2; sym_intent intent:2; *************** typedef struct *** 498,510 **** } locus; - #include - #ifndef PATH_MAX - # include - # define PATH_MAX MAXPATHLEN - #endif - - extern int gfc_suppress_error; --- 508,513 ---- *************** typedef struct gfc_symbol *** 690,695 **** --- 693,703 ---- gfc_component *components; /* Derived type components */ struct gfc_symbol *common_next; /* Links for COMMON syms */ + + /* This is in fact a gfc_common_head but it is only used for pointer + comparisons to check if symbols are in the same common block. */ + struct gfc_common_head* common_head; + /* Make sure setup code for dummy arguments is generated in the correct order. */ int dummy_order; *************** gfc_symbol; *** 718,729 **** /* This structure is used to keep track of symbols in common blocks. */ ! typedef struct { locus where; int use_assoc, saved; char name[GFC_MAX_SYMBOL_LEN + 1]; ! gfc_symbol *head; } gfc_common_head; --- 726,737 ---- /* This structure is used to keep track of symbols in common blocks. */ ! typedef struct gfc_common_head { locus where; int use_assoc, saved; char name[GFC_MAX_SYMBOL_LEN + 1]; ! struct gfc_symbol *head; } gfc_common_head; *************** typedef struct gfc_expr *** 1065,1070 **** --- 1073,1081 ---- locus where; + /* True if it is converted from Hollerith constant. */ + unsigned int from_H : 1; + union { int logical; *************** typedef struct gfc_equiv *** 1175,1180 **** --- 1186,1192 ---- { struct gfc_equiv *next, *eq; gfc_expr *expr; + const char *module; int used; } gfc_equiv; *************** typedef struct *** 1420,1425 **** --- 1432,1438 ---- int flag_pack_derived; int flag_repack_arrays; int flag_f2c; + int flag_automatic; int flag_backslash; int q_kind; *************** const char * gfc_get_string (const char *** 1533,1539 **** typedef struct gfc_error_buf { int flag; ! char message[MAX_ERROR_MESSAGE]; } gfc_error_buf; void gfc_error_init_1 (void); --- 1546,1553 ---- typedef struct gfc_error_buf { int flag; ! size_t allocated, index; ! char *message; } gfc_error_buf; void gfc_error_init_1 (void); *************** try gfc_notify_std (int, const char *, . *** 1559,1564 **** --- 1573,1579 ---- void gfc_push_error (gfc_error_buf *); 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); *************** int gfc_pure (gfc_symbol *); *** 1762,1767 **** --- 1777,1783 ---- int gfc_elemental (gfc_symbol *); try gfc_resolve_iterator (gfc_iterator *, bool); try gfc_resolve_index (gfc_expr *, int); + try gfc_resolve_dim_arg (gfc_expr *); /* array.c */ void gfc_free_array_spec (gfc_array_spec *); diff -Nrcpad gcc-4.0.1/gcc/fortran/gfortran.texi gcc-4.0.2/gcc/fortran/gfortran.texi *** gcc-4.0.1/gcc/fortran/gfortran.texi Mon Jun 20 20:16:55 2005 --- gcc-4.0.2/gcc/fortran/gfortran.texi Sun Aug 14 21:46:51 2005 *************** Variable for swapping Endianness during *** 623,634 **** @command{gfortran} implements a number of extensions over standard Fortran. This chapter contains information on their syntax and ! meaning. @menu * Old-style kind specifications:: * Old-style variable initialization:: * Extensions to namelist:: @end menu @node Old-style kind specifications --- 623,643 ---- @command{gfortran} implements a number of extensions over standard Fortran. This chapter contains information on their syntax and ! meaning. There are currently two categories of @command{gfortran} ! extensions, those that provide functionality beyond that provided ! by any standard, and those that are supported by @command{gfortran} ! purely for backward compatibility with legacy compilers. By default, ! @option{-std=gnu} allows the compiler to accept both types of ! extensions, but to warn about the use of the latter. Specifying ! either @option{-std=f95} or @option{-std=f2003} disables both types ! of extensions, and @option{-std=legacy} allows both without warning. @menu * Old-style kind specifications:: * Old-style variable initialization:: * Extensions to namelist:: + * Implicitly interconvert LOGICAL and INTEGER:: + * Hollerith constants support:: @end menu @node Old-style kind specifications *************** had been called: *** 725,730 **** --- 734,793 ---- To aid this dialog, when input is from stdin, errors produce send their messages to stderr and execution continues, even if IOSTAT is set. + PRINT namelist is permitted. This causes an error if -std=f95 is used. + @smallexample + PROGRAM test_print + REAL, dimension (4) :: x = (/1.0, 2.0, 3.0, 4.0/) + NAMELIST /mynml/ x + PRINT mynml + END PROGRAM test_print + @end smallexample + + @node Implicitly interconvert LOGICAL and INTEGER + @section Implicitly interconvert LOGICAL and INTEGER + @cindex Implicitly interconvert LOGICAL and INTEGER + + As a GNU extension for backwards compatability with other compilers, + @command{gfortran} allows the implicit conversion of LOGICALs to INTEGERs + and vice versa. When converting from a LOGICAL to an INTEGER, the numeric + value of @code{.FALSE.} is zero, and that of @code{.TRUE.} is one. When + converting from INTEGER to LOGICAL, the value zero is interpreted as + @code{.FALSE.} and any non-zero value is interpreted as @code{.TRUE.}. + + @smallexample + INTEGER*4 i + i = .FALSE. + @end smallexample + + @node Hollerith constants support + @section Hollerith constants support + @cindex Hollerith constants + + A Hollerith constant is a string of characters preceded by the letter @samp{H} + or @samp{h}, and there must be an literal, unsigned, nonzero default integer + constant indicating the number of characters in the string. Hollerith constants + are stored as byte strings, one character per byte. + + @command{gfortran} supports Hollerith constants. They can be used as the right + hands in the @code{DATA} statement and @code{ASSIGN} statement, also as the + arguments. The left hands can be of Integer, Real, Complex and Logical type. + The constant will be padded or trancated to fit the size of left hand. + + Valid Hollerith constants examples: + @smallexample + complex*16 x(2) + data x /16Habcdefghijklmnop, 16Hqrstuvwxyz012345/ + call foo (4H abc) + x(1) = 16Habcdefghijklmnop + @end smallexample + + Invalid Hollerith constants examples: + @smallexample + integer*4 a + a = 8H12345678 ! The Hollerith constant is too long. It will be truncated. + a = 0H ! At least one character needed. + @end smallexample + @include intrinsic.texi @c --------------------------------------------------------------------- @c Contributing diff -Nrcpad gcc-4.0.1/gcc/fortran/intrinsic.c gcc-4.0.2/gcc/fortran/intrinsic.c *** gcc-4.0.1/gcc/fortran/intrinsic.c Mon Jun 20 13:05:15 2005 --- gcc-4.0.2/gcc/fortran/intrinsic.c Tue Aug 9 17:44:02 2005 *************** gfc_type_letter (bt type) *** 79,84 **** --- 79,88 ---- c = 'c'; break; + case BT_HOLLERITH: + c = 'h'; + break; + default: c = 'u'; break; *************** add_functions (void) *** 1434,1439 **** --- 1438,1449 ---- make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU); + add_sym_1 ("isatty", 0, 0, BT_LOGICAL, dl, GFC_STD_GNU, + gfc_check_isatty, NULL, gfc_resolve_isatty, + ut, BT_INTEGER, di, REQUIRED); + + make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU); + add_sym_2 ("ishft", 1, 1, BT_INTEGER, di, GFC_STD_F95, gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft, i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); *************** add_subroutines (void) *** 2213,2218 **** --- 2223,2232 ---- c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL, cm, BT_INTEGER, di, OPTIONAL); + add_sym_2s ("ttynam", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub, + ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED); + add_sym_2s ("umask", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_umask_sub, NULL, gfc_resolve_umask_sub, val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL); *************** add_subroutines (void) *** 2227,2234 **** /* Add a function to the list of conversion symbols. */ static void ! add_conv (bt from_type, int from_kind, bt to_type, int to_kind, ! gfc_expr * (*simplify) (gfc_expr *, bt, int)) { gfc_typespec from, to; --- 2241,2247 ---- /* Add a function to the list of conversion symbols. */ static void ! add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard) { gfc_typespec from, to; *************** add_conv (bt from_type, int from_kind, b *** 2250,2258 **** sym = conversion + nconv; ! sym->name = conv_name (&from, &to); sym->lib_name = sym->name; ! sym->simplify.cc = simplify; sym->elemental = 1; sym->ts = to; sym->generic_id = GFC_ISYM_CONVERSION; --- 2263,2272 ---- sym = conversion + nconv; ! sym->name = conv_name (&from, &to); sym->lib_name = sym->name; ! sym->simplify.cc = gfc_convert_constant; ! sym->standard = standard; sym->elemental = 1; sym->ts = to; sym->generic_id = GFC_ISYM_CONVERSION; *************** add_conversions (void) *** 2277,2283 **** continue; add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, ! BT_INTEGER, gfc_integer_kinds[j].kind, gfc_convert_constant); } /* Integer-Real/Complex conversions. */ --- 2291,2297 ---- continue; add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, ! BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77); } /* Integer-Real/Complex conversions. */ *************** add_conversions (void) *** 2285,2302 **** for (j = 0; gfc_real_kinds[j].kind != 0; j++) { add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, ! BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant); add_conv (BT_REAL, gfc_real_kinds[j].kind, ! BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant); add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, ! BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant); add_conv (BT_COMPLEX, gfc_real_kinds[j].kind, ! BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant); } /* Real/Complex - Real/Complex conversions. */ for (i = 0; gfc_real_kinds[i].kind != 0; i++) for (j = 0; gfc_real_kinds[j].kind != 0; j++) --- 2299,2341 ---- for (j = 0; gfc_real_kinds[j].kind != 0; j++) { add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, ! BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); add_conv (BT_REAL, gfc_real_kinds[j].kind, ! BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77); add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, ! BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); add_conv (BT_COMPLEX, gfc_real_kinds[j].kind, ! BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77); } + if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0) + { + /* Hollerith-Integer conversions. */ + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + add_conv (BT_HOLLERITH, gfc_default_character_kind, + BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); + /* Hollerith-Real conversions. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + add_conv (BT_HOLLERITH, gfc_default_character_kind, + BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY); + /* Hollerith-Complex conversions. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + add_conv (BT_HOLLERITH, gfc_default_character_kind, + BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY); + + /* Hollerith-Character conversions. */ + add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER, + gfc_default_character_kind, GFC_STD_LEGACY); + + /* Hollerith-Logical conversions. */ + for (i = 0; gfc_logical_kinds[i].kind != 0; i++) + add_conv (BT_HOLLERITH, gfc_default_character_kind, + BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY); + } + /* Real/Complex - Real/Complex conversions. */ for (i = 0; gfc_real_kinds[i].kind != 0; i++) for (j = 0; gfc_real_kinds[j].kind != 0; j++) *************** add_conversions (void) *** 2304,2320 **** if (i != j) { add_conv (BT_REAL, gfc_real_kinds[i].kind, ! BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant); add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, ! BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant); } add_conv (BT_REAL, gfc_real_kinds[i].kind, ! BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant); add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, ! BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant); } /* Logical/Logical kind conversion. */ --- 2343,2359 ---- if (i != j) { add_conv (BT_REAL, gfc_real_kinds[i].kind, ! BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, ! BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); } add_conv (BT_REAL, gfc_real_kinds[i].kind, ! BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, ! BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); } /* Logical/Logical kind conversion. */ *************** add_conversions (void) *** 2325,2332 **** continue; add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind, ! BT_LOGICAL, gfc_logical_kinds[j].kind, gfc_convert_constant); } } --- 2364,2382 ---- continue; add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind, ! BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77); } + + /* Integer-Logical and Logical-Integer conversions. */ + if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0) + for (i=0; gfc_integer_kinds[i].kind; i++) + for (j=0; gfc_logical_kinds[j].kind; j++) + { + add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, + BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY); + add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind, + BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); + } } *************** do_simplify (gfc_intrinsic_sym * specifi *** 2672,2677 **** --- 2722,2737 ---- gfc_expr *result, *a1, *a2, *a3, *a4, *a5; gfc_actual_arglist *arg; + /* Check the arguments if there are Hollerith constants. We deal with + them at run-time. */ + for (arg = e->value.function.actual; arg != NULL; arg = arg->next) + { + if (arg->expr && arg->expr->from_H) + { + result = NULL; + goto finish; + } + } /* Max and min require special handling due to the variable number of args. */ if (specific->simplify.f1 == gfc_simplify_min) *************** got_specific: *** 2996,3006 **** expr->value.function.isym = specific; gfc_intrinsic_symbol (expr->symtree->n.sym); if (do_simplify (specific, expr) == FAILURE) ! { ! gfc_suppress_error = 0; ! return MATCH_ERROR; ! } /* TODO: We should probably only allow elemental functions here. */ flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER); --- 3056,3064 ---- expr->value.function.isym = specific; gfc_intrinsic_symbol (expr->symtree->n.sym); + gfc_suppress_error = 0; if (do_simplify (specific, expr) == FAILURE) ! return MATCH_ERROR; /* TODO: We should probably only allow elemental functions here. */ flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER); *************** gfc_convert_type_warn (gfc_expr * expr, *** 3142,3148 **** goto bad; /* At this point, a conversion is necessary. A warning may be needed. */ ! if (wflag && gfc_option.warn_conversion) gfc_warning_now ("Conversion from %s to %s at %L", gfc_typename (&from_ts), gfc_typename (ts), &expr->where); --- 3200,3209 ---- goto bad; /* At this point, a conversion is necessary. A warning may be needed. */ ! if ((gfc_option.warn_std & sym->standard) != 0) ! gfc_warning_now ("Extension: Conversion from %s to %s at %L", ! gfc_typename (&from_ts), gfc_typename (ts), &expr->where); ! else if (wflag && gfc_option.warn_conversion) gfc_warning_now ("Conversion from %s to %s at %L", gfc_typename (&from_ts), gfc_typename (ts), &expr->where); diff -Nrcpad gcc-4.0.1/gcc/fortran/intrinsic.h gcc-4.0.2/gcc/fortran/intrinsic.h *** gcc-4.0.1/gcc/fortran/intrinsic.h Mon Apr 25 00:09:13 2005 --- gcc-4.0.2/gcc/fortran/intrinsic.h Tue Aug 9 17:44:03 2005 *************** try gfc_check_index (gfc_expr *, gfc_exp *** 70,75 **** --- 70,76 ---- try gfc_check_int (gfc_expr *, gfc_expr *); try gfc_check_ior (gfc_expr *, gfc_expr *); try gfc_check_irand (gfc_expr *); + try gfc_check_isatty (gfc_expr *); try gfc_check_ishft (gfc_expr *, gfc_expr *); try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_kill (gfc_expr *, gfc_expr *); *************** try gfc_check_symlnk_sub (gfc_expr *, gf *** 148,153 **** --- 149,155 ---- try gfc_check_sleep_sub (gfc_expr *); try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_system_sub (gfc_expr *, gfc_expr *); + try gfc_check_ttynam_sub (gfc_expr *, gfc_expr *); try gfc_check_umask_sub (gfc_expr *, gfc_expr *); try gfc_check_unlink_sub (gfc_expr *, gfc_expr *); *************** void gfc_resolve_ichar (gfc_expr *, gfc_ *** 310,315 **** --- 312,318 ---- void gfc_resolve_idnint (gfc_expr *, gfc_expr *); void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *); + void gfc_resolve_isatty (gfc_expr *, gfc_expr *); void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *); *************** void gfc_resolve_sleep_sub (gfc_code *); *** 396,401 **** --- 399,405 ---- void gfc_resolve_stat_sub (gfc_code *); void gfc_resolve_system_clock (gfc_code *); void gfc_resolve_system_sub (gfc_code *); + void gfc_resolve_ttynam_sub (gfc_code *); void gfc_resolve_umask_sub (gfc_code *); void gfc_resolve_unlink_sub (gfc_code *); diff -Nrcpad gcc-4.0.1/gcc/fortran/intrinsic.texi gcc-4.0.2/gcc/fortran/intrinsic.texi *** gcc-4.0.1/gcc/fortran/intrinsic.texi Sat May 28 16:09:24 2005 --- gcc-4.0.2/gcc/fortran/intrinsic.texi Mon Aug 1 05:28:11 2005 *************** and editing. All contributions and corr *** 36,42 **** * @code{ABORT}: ABORT, Abort the program * @code{ABS}: ABS, Absolute value * @code{ACHAR}: ACHAR, Character in @acronym{ASCII} collating sequence ! * @code{ACOS}: ACOS, Arccosine function * @code{ADJUSTL}: ADJUSTL, Left adjust a string * @code{ADJUSTR}: ADJUSTR, Right adjust a string * @code{AIMAG}: AIMAG, Imaginary part of complex number --- 36,42 ---- * @code{ABORT}: ABORT, Abort the program * @code{ABS}: ABS, Absolute value * @code{ACHAR}: ACHAR, Character in @acronym{ASCII} collating sequence ! * @code{ACOS}: ACOS, Arc cosine function * @code{ADJUSTL}: ADJUSTL, Left adjust a string * @code{ADJUSTR}: ADJUSTR, Right adjust a string * @code{AIMAG}: AIMAG, Imaginary part of complex number *************** and editing. All contributions and corr *** 60,70 **** * @code{CEILING}: CEILING, Integer ceiling function * @code{CHAR}: CHAR, Character conversion function * @code{CMPLX}: CMPLX, Complex conversion function * @code{COS}: COS, Cosine function * @code{COSH}: COSH, Hyperbolic cosine function * @code{ERF}: ERF, Error function * @code{ERFC}: ERFC, Complementary error function ! * @code{EXP}: EXP, Cosine function * @code{LOG}: LOG, Logarithm function * @code{LOG10}: LOG10, Base 10 logarithm function * @code{SQRT}: SQRT, Square-root function --- 60,92 ---- * @code{CEILING}: CEILING, Integer ceiling function * @code{CHAR}: CHAR, Character conversion function * @code{CMPLX}: CMPLX, Complex conversion function + * @code{COMMAND_ARGUMENT_COUNT}: COMMAND_ARGUMENT_COUNT, Command line argument count + * @code{CONJG}: CONJG, Complex conjugate function * @code{COS}: COS, Cosine function * @code{COSH}: COSH, Hyperbolic cosine function + * @code{COUNT}: COUNT, Count occurrences of .TRUE. in an array + * @code{CPU_TIME}: CPU_TIME, CPU time subroutine + * @code{CSHIFT}: CSHIFT, Circular array shift function + * @code{DATE_AND_TIME}: DATE_AND_TIME, Date and time subroutine + * @code{DBLE}: DBLE, Double precision conversion function + * @code{DCMPLX}: DCMPLX, Double complex conversion function + * @code{DFLOAT}: DFLOAT, Double precision conversion function + * @code{DIGITS}: DIGITS, Significant digits function + * @code{DIM}: DIM, Dim function + * @code{DOT_PRODUCT}: DOT_PRODUCT, Dot product function + * @code{DPROD}: DPROD, Double product function + * @code{DREAL}: DREAL, Double real part function + * @code{DTIME}: DTIME, Execution time subroutine (or function) + * @code{EOSHIFT}: EOSHIFT, End-off shift function + * @code{EPSILON}: EPSILON, Epsilon function * @code{ERF}: ERF, Error function * @code{ERFC}: ERFC, Complementary error function ! * @code{ETIME}: ETIME, Execution time subroutine (or function) ! * @code{EXIT}: EXIT, Exit the program with status. ! * @code{EXP}: EXP, Exponential function ! * @code{EXPONENT}: EXPONENT, Exponent function ! * @code{FLOOR}: FLOOR, Integer floor function ! * @code{FNUM}: FNUM, File number function * @code{LOG}: LOG, Logarithm function * @code{LOG10}: LOG10, Base 10 logarithm function * @code{SQRT}: SQRT, Square-root function *************** the Fortran 95 standard. Gfortran defin *** 90,96 **** default real type by @code{INTEGER(KIND=4)} and @code{REAL(KIND=4)}, respectively. The standard mandates that both data types shall have another kind, which have more precision. On typical target architectures ! supports by @command{gfortran}, this kind type parameter is @code{KIND=8}. Hence, @code{REAL(KIND=8)} and @code{DOUBLE PRECISION} are equivalent. In the description of generic intrinsic procedures, the kind type parameter will be specified by @code{KIND=*}, and in the description of specific --- 112,118 ---- default real type by @code{INTEGER(KIND=4)} and @code{REAL(KIND=4)}, respectively. The standard mandates that both data types shall have another kind, which have more precision. On typical target architectures ! supported by @command{gfortran}, this kind type parameter is @code{KIND=8}. Hence, @code{REAL(KIND=8)} and @code{DOUBLE PRECISION} are equivalent. In the description of generic intrinsic procedures, the kind type parameter will be specified by @code{KIND=*}, and in the description of specific *************** and denotes such arguments by square bra *** 105,111 **** @command{Gfortran} offers the @option{-std=f95} and @option{-std=gnu} options, which can be used to restrict the set of intrinsic procedures to a given standard. By default, @command{gfortran} sets the @option{-std=gnu} ! option, and so all intrinsic procedures describe here are accepted. There is one caveat. For a select group of intrinsic procedures, @command{g77} implemented both a function and a subroutine. Both classes have been implemented in @command{gfortran} for backwards compatibility --- 127,133 ---- @command{Gfortran} offers the @option{-std=f95} and @option{-std=gnu} options, which can be used to restrict the set of intrinsic procedures to a given standard. By default, @command{gfortran} sets the @option{-std=gnu} ! option, and so all intrinsic procedures described here are accepted. There is one caveat. For a select group of intrinsic procedures, @command{g77} implemented both a function and a subroutine. Both classes have been implemented in @command{gfortran} for backwards compatibility *************** end program test_achar *** 248,261 **** @node ACOS ! @section @code{ACOS} --- Arccosine function @findex @code{ACOS} intrinsic @findex @code{DACOS} intrinsic ! @cindex arccosine @table @asis @item @emph{Description}: ! @code{ACOS(X)} computes the arccosine of its @var{X}. @item @emph{Option}: f95, gnu --- 270,283 ---- @node ACOS ! @section @code{ACOS} --- Arc cosine function @findex @code{ACOS} intrinsic @findex @code{DACOS} intrinsic ! @cindex arc cosine @table @asis @item @emph{Description}: ! @code{ACOS(X)} computes the arc cosine of @var{X}. @item @emph{Option}: f95, gnu *************** elemental function *** 268,274 **** @item @emph{Arguments}: @multitable @columnfractions .15 .80 ! @item @var{X} @tab The type shall be @code{REAL(*)}, and a magnitude that is less than one. @end multitable --- 290,296 ---- @item @emph{Arguments}: @multitable @columnfractions .15 .80 ! @item @var{X} @tab The type shall be @code{REAL(*)} with a magnitude that is less than one. @end multitable *************** f95, gnu *** 441,447 **** elemental function @item @emph{Syntax}: ! @code{X = AINT(X)} @* @code{X = AINT(X, KIND)} @item @emph{Arguments}: --- 463,469 ---- elemental function @item @emph{Syntax}: ! @code{X = AINT(X)} @code{X = AINT(X, KIND)} @item @emph{Arguments}: *************** initialization expression. *** 453,459 **** @item @emph{Return value}: The return value is of type real with the kind type parameter of the ! argument if the optional @var{KIND} is absence; otherwise, the kind type parameter will be given by @var{KIND}. If the magnitude of @var{X} is less than one, then @code{AINT(X)} returns zero. If the magnitude is equal to or greater than one, then it returns the largest --- 475,481 ---- @item @emph{Return value}: The return value is of type real with the kind type parameter of the ! argument if the optional @var{KIND} is absent; otherwise, the kind type parameter will be given by @var{KIND}. If the magnitude of @var{X} is less than one, then @code{AINT(X)} returns zero. If the magnitude is equal to or greater than one, then it returns the largest *************** f95, gnu *** 498,504 **** transformational function @item @emph{Syntax}: ! @code{L = ALL(MASK)} @* @code{L = ALL(MASK, DIM)} @item @emph{Arguments}: --- 520,526 ---- transformational function @item @emph{Syntax}: ! @code{L = ALL(MASK)} @code{L = ALL(MASK, DIM)} @item @emph{Arguments}: *************** end program test_all *** 555,561 **** @table @asis @item @emph{Description}: ! @code{ALLOCATED(X)} checks the status of wether @var{X} is allocated. @item @emph{Option}: f95, gnu --- 577,583 ---- @table @asis @item @emph{Description}: ! @code{ALLOCATED(X)} checks the status of whether @var{X} is allocated. @item @emph{Option}: f95, gnu *************** f95, gnu *** 605,611 **** elemental function @item @emph{Syntax}: ! @code{X = ANINT(X)} @* @code{X = ANINT(X, KIND)} @item @emph{Arguments}: --- 627,633 ---- elemental function @item @emph{Syntax}: ! @code{X = ANINT(X)} @code{X = ANINT(X, KIND)} @item @emph{Arguments}: *************** initialization expression. *** 617,623 **** @item @emph{Return value}: The return value is of type real with the kind type parameter of the ! argument if the optional @var{KIND} is absence; otherwise, the kind type parameter will be given by @var{KIND}. If @var{X} is greater than zero, then @code{ANINT(X)} returns @code{AINT(X+0.5)}. If @var{X} is less than or equal to zero, then return @code{AINT(X-0.5)}. --- 639,645 ---- @item @emph{Return value}: The return value is of type real with the kind type parameter of the ! argument if the optional @var{KIND} is absent; otherwise, the kind type parameter will be given by @var{KIND}. If @var{X} is greater than zero, then @code{ANINT(X)} returns @code{AINT(X+0.5)}. If @var{X} is less than or equal to zero, then return @code{AINT(X-0.5)}. *************** end program test_anint *** 650,657 **** @table @asis @item @emph{Description}: ! @code{ANY(MASK [, DIM])} determines if any of the values is true in @var{MASK} ! in the array along dimension @var{DIM}. @item @emph{Option}: f95, gnu --- 672,679 ---- @table @asis @item @emph{Description}: ! @code{ANY(MASK [, DIM])} determines if any of the values in the logical array ! @var{MASK} along dimension @var{DIM} are @code{.TRUE.}. @item @emph{Option}: f95, gnu *************** f95, gnu *** 660,666 **** transformational function @item @emph{Syntax}: ! @code{L = ANY(MASK)} @* @code{L = ANY(MASK, DIM)} @item @emph{Arguments}: --- 682,688 ---- transformational function @item @emph{Syntax}: ! @code{L = ANY(MASK)} @code{L = ANY(MASK, DIM)} @item @emph{Arguments}: *************** f95, gnu *** 774,780 **** inquiry function @item @emph{Syntax}: ! @code{L = ASSOCIATED(PTR)} @* @code{L = ASSOCIATED(PTR [, TGT])} @item @emph{Arguments}: --- 796,802 ---- inquiry function @item @emph{Syntax}: ! @code{L = ASSOCIATED(PTR)} @code{L = ASSOCIATED(PTR [, TGT])} @item @emph{Arguments}: *************** end program test_besyn *** 1210,1216 **** @table @asis @item @emph{Description}: ! @code{BIT_SIZE(I)} returns the number of bits (integer precision plus sign bit) represented by the type of @var{I}. @item @emph{Option}: f95, gnu --- 1232,1239 ---- @table @asis @item @emph{Description}: ! @code{BIT_SIZE(I)} returns the number of bits (integer precision plus sign bit) ! represented by the type of @var{I}. @item @emph{Option}: f95, gnu *************** end program test_bit_size *** 1249,1255 **** @table @asis @item @emph{Description}: ! @code{BTEST(I,POS)} returns logical .TRUE. if the bit at @var{POS} in @var{I} is set. @item @emph{Option}: f95, gnu --- 1272,1279 ---- @table @asis @item @emph{Description}: ! @code{BTEST(I,POS)} returns logical @code{.TRUE.} if the bit at @var{POS} ! in @var{I} is set. @item @emph{Option}: f95, gnu *************** end program test_btest *** 1292,1298 **** @table @asis @item @emph{Description}: ! @code{CEILING(X,[KIND])} returns the least integer greater than or equal to @var{X}. @item @emph{Option}: f95, gnu --- 1316,1322 ---- @table @asis @item @emph{Description}: ! @code{CEILING(X)} returns the least integer greater than or equal to @var{X}. @item @emph{Option}: f95, gnu *************** f95, gnu *** 1301,1307 **** elemental function @item @emph{Syntax}: ! @code{X = CEILING(X)} @item @emph{Arguments}: @multitable @columnfractions .15 .80 --- 1325,1331 ---- elemental function @item @emph{Syntax}: ! @code{I = CEILING(X[,KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .80 *************** f95, gnu *** 1341,1347 **** elemental function @item @emph{Syntax}: ! @code{C = CHAR(I)} @item @emph{Arguments}: @multitable @columnfractions .15 .80 --- 1365,1371 ---- elemental function @item @emph{Syntax}: ! @code{C = CHAR(I[,KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .80 *************** end program test_char *** 1372,1378 **** @table @asis @item @emph{Description}: ! @code{CMPLX(X,[Y,KIND])} returns a complex number where @var{X} is converted to the real component. If @var{Y} is present it is converted to the imaginary component. If @var{Y} is not present then the imaginary component is set to 0.0. If @var{X} is complex then @var{Y} must not be present. @item @emph{Option}: --- 1396,1404 ---- @table @asis @item @emph{Description}: ! @code{CMPLX(X,[Y,KIND])} returns a complex number where @var{X} is converted to ! the real component. If @var{Y} is present it is converted to the imaginary ! component. If @var{Y} is not present then the imaginary component is set to 0.0. If @var{X} is complex then @var{Y} must not be present. @item @emph{Option}: *************** f95, gnu *** 1382,1394 **** elemental function @item @emph{Syntax}: ! @code{C = CMPLX(X)} ! @code{C = CMPLX(X,Y)} ! @code{C = CMPLX(X,Y,KIND)} @item @emph{Arguments}: @multitable @columnfractions .15 .80 ! @item @var{X} @tab The type may be @code{INTEGER(*)} or @code{REAL(*)} or @code{COMPLEX(*)}. @item @var{Y} @tab Optional, allowed if @var{X} is not @code{COMPLEX(*)}. May be @code{INTEGER(*)} or @code{REAL(*)}. @item @var{KIND} @tab Optional scaler integer initialization expression. @end multitable --- 1408,1418 ---- elemental function @item @emph{Syntax}: ! @code{C = CMPLX(X[,Y,KIND])} @item @emph{Arguments}: @multitable @columnfractions .15 .80 ! @item @var{X} @tab The type may be @code{INTEGER(*)}, @code{REAL(*)}, or @code{COMPLEX(*)}. @item @var{Y} @tab Optional, allowed if @var{X} is not @code{COMPLEX(*)}. May be @code{INTEGER(*)} or @code{REAL(*)}. @item @var{KIND} @tab Optional scaler integer initialization expression. @end multitable *************** end program test_cmplx *** 1410,1415 **** --- 1434,1526 ---- + @node COMMAND_ARGUMENT_COUNT + @section @code{COMMAND_ARGUMENT_COUNT} --- Argument count function + @findex @code{COMMAND_ARGUMENT_COUNT} intrinsic + @cindex command argument count + + @table @asis + @item @emph{Description}: + @code{COMMAND_ARGUMENT_COUNT()} returns the number of arguments passed on the + command line when the containing program was invoked. + + @item @emph{Option}: + f2003, gnu + + @item @emph{Class}: + non-elemental function + + @item @emph{Syntax}: + @code{I = COMMAND_ARGUMENT_COUNT()} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item None + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER(4)} + + @item @emph{Example}: + @smallexample + program test_command_argument_count + integer :: count + count = command_argument_count() + print *, count + end program test_command_argument_count + @end smallexample + @end table + + + + @node CONJG + @section @code{CONJG} --- Complex conjugate function + @findex @code{CONJG} intrinsic + @findex @code{DCONJG} intrinsic + @cindex complex conjugate + @table @asis + @item @emph{Description}: + @code{CONJG(Z)} returns the conjugate of @var{Z}. If @var{Z} is @code{(x, y)} + then the result is @code{(x, -y)} + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{Z = CONJG(Z)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{Z} @tab The type shall be @code{COMPLEX(*)}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{COMPLEX(*)}. + + @item @emph{Example}: + @smallexample + program test_conjg + complex :: z = (2.0, 3.0) + complex(8) :: dz = (2.71_8, -3.14_8) + z= conjg(z) + print *, z + dz = dconjg(dz) + print *, dz + end program test_conjg + @end smallexample + + @item @emph{Specific names}: + @multitable @columnfractions .24 .24 .24 .24 + @item Name @tab Argument @tab Return type @tab Option + @item @code{DCONJG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab gnu + @end multitable + @end table + + + @node COS @section @code{COS} --- Cosine function @findex @code{COS} intrinsic *************** elemental function *** 1438,1444 **** @end multitable @item @emph{Return value}: ! The return value has same type and kind than @var{X}. @item @emph{Example}: @smallexample --- 1549,1555 ---- @end multitable @item @emph{Return value}: ! The return value has the same type and kind as @var{X}. @item @emph{Example}: @smallexample *************** end program test_cos *** 1450,1460 **** @item @emph{Specific names}: @multitable @columnfractions .24 .24 .24 .24 ! @item Name @tab Argument @tab Return type @tab Option ! @item @code{DCOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu ! @item @code{CCOS(X)} @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab f95, gnu ! @item @code{ZCOS(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu ! @item @code{CDCOS(X)} @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab f95, gnu @end multitable @end table --- 1561,1571 ---- @item @emph{Specific names}: @multitable @columnfractions .24 .24 .24 .24 ! @item Name @tab Argument @tab Return type @tab Option ! @item @code{DCOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab f95, gnu ! @item @code{CCOS(X)}@tab @code{COMPLEX(4) X}@tab @code{COMPLEX(4)}@tab f95, gnu ! @item @code{ZCOS(X)}@tab @code{COMPLEX(8) X}@tab @code{COMPLEX(8)}@tab f95, gnu ! @item @code{CDCOS(X)}@tab @code{COMPLEX(8) X}@tab @code{COMPLEX(8)}@tab f95, gnu @end multitable @end table *************** end program test_cosh *** 1505,1510 **** --- 1616,2350 ---- + @node COUNT + @section @code{COUNT} --- Count function + @findex @code{COUNT} intrinsic + @cindex count + + @table @asis + @item @emph{Description}: + @code{COUNT(MASK[,DIM])} counts the number of @code{.TRUE.} elements of + @var{MASK} along the dimension of @var{DIM}. If @var{DIM} is omitted it is + taken to be @code{1}. @var{DIM} is a scaler of type @code{INTEGER} in the + range of @math{1 /leq DIM /leq n)} where @math{n} is the rank of @var{MASK}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + transformational function + + @item @emph{Syntax}: + @code{I = COUNT(MASK[,DIM])} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{MASK} @tab The type shall be @code{LOGICAL}. + @item @var{DIM} @tab The type shall be @code{INTEGER}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER} with rank equal to that of + @var{MASK}. + + @item @emph{Example}: + @smallexample + program test_count + integer, dimension(2,3) :: a, b + logical, dimension(2,3) :: mask + a = reshape( (/ 1, 2, 3, 4, 5, 6 /), (/ 2, 3 /)) + b = reshape( (/ 0, 7, 3, 4, 5, 8 /), (/ 2, 3 /)) + print '(3i3)', a(1,:) + print '(3i3)', a(2,:) + print * + print '(3i3)', b(1,:) + print '(3i3)', b(2,:) + print * + mask = a.ne.b + print '(3l3)', mask(1,:) + print '(3l3)', mask(2,:) + print * + print '(3i3)', count(mask) + print * + print '(3i3)', count(mask, 1) + print * + print '(3i3)', count(mask, 2) + end program test_count + @end smallexample + @end table + + + + @node CPU_TIME + @section @code{CPU_TIME} --- CPU elapsed time in seconds + @findex @code{CPU_TIME} intrinsic + @cindex CPU_TIME + + @table @asis + @item @emph{Description}: + Returns a @code{REAL} value representing the elapsed CPU time in seconds. This + is useful for testing segments of code to determine execution time. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + subroutine + + @item @emph{Syntax}: + @code{CPU_TIME(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type shall be @code{REAL} with intent out. + @end multitable + + @item @emph{Return value}: + None + + @item @emph{Example}: + @smallexample + program test_cpu_time + real :: start, finish + call cpu_time(start) + ! put code to test here + call cpu_time(finish) + print '("Time = ",f6.3," seconds.")',finish-start + end program test_cpu_time + @end smallexample + @end table + + + + @node CSHIFT + @section @code{CSHIFT} --- Circular shift function + @findex @code{CSHIFT} intrinsic + @cindex cshift intrinsic + + @table @asis + @item @emph{Description}: + @code{CSHIFT(ARRAY, SHIFT[,DIM])} performs a circular shift on elements of + @var{ARRAY} along the dimension of @var{DIM}. If @var{DIM} is omitted it is + taken to be @code{1}. @var{DIM} is a scaler of type @code{INTEGER} in the + range of @math{1 /leq DIM /leq n)} where @math{n} is the rank of @var{ARRAY}. + If the rank of @var{ARRAY} is one, then all elements of @var{ARRAY} are shifted + by @var{SHIFT} places. If rank is greater than one, then all complete rank one + sections of @var{ARRAY} along the given dimension are shifted. Elements + shifted out one end of each rank one section are shifted back in the other end. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + transformational function + + @item @emph{Syntax}: + @code{A = CSHIFT(A, SHIFT[,DIM])} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{ARRAY} @tab May be any type, not scaler. + @item @var{SHIFT} @tab The type shall be @code{INTEGER}. + @item @var{DIM} @tab The type shall be @code{INTEGER}. + @end multitable + + @item @emph{Return value}: + Returns an array of same type and rank as the @var{ARRAY} argument. + + @item @emph{Example}: + @smallexample + program test_cshift + integer, dimension(3,3) :: a + a = reshape( (/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /), (/ 3, 3 /)) + print '(3i3)', a(1,:) + print '(3i3)', a(2,:) + print '(3i3)', a(3,:) + a = cshift(a, SHIFT=(/1, 2, -1/), DIM=2) + print * + print '(3i3)', a(1,:) + print '(3i3)', a(2,:) + print '(3i3)', a(3,:) + end program test_cshift + @end smallexample + @end table + + + + @node DATE_AND_TIME + @section @code{DATE_AND_TIME} --- Date and time subroutine + @findex @code{DATE_AND_TIME} intrinsic + @cindex DATE_AND_TIME + + @table @asis + @item @emph{Description}: + @code{DATE_AND_TIME(DATE, TIME, ZONE, VALUES)} gets the corresponding date and + time information from the real-time system clock. @var{DATE} is + @code{INTENT(OUT)} and has form ccyymmdd. @var{TIME} is @code{INTENT(OUT)} and + has form hhmmss.sss. @var{ZONE} is @code{INTENT(OUT)} and has form (+-)hhmm, + representing the difference with respect to Coordinated Universal Time (UTC). + Unavailable time and date parameters return blanks. + + @var{VALUES} is @code{INTENT(OUT)} and provides the following: + + @multitable @columnfractions .15 .30 .60 + @item @tab @code{VALUE(1)}: @tab The year + @item @tab @code{VALUE(2)}: @tab The month + @item @tab @code{VALUE(3)}: @tab The day of the month + @item @tab @code{VAlUE(4)}: @tab Time difference with UTC in minutes + @item @tab @code{VALUE(5)}: @tab The hour of the day + @item @tab @code{VALUE(6)}: @tab The minutes of the hour + @item @tab @code{VALUE(7)}: @tab The seconds of the minute + @item @tab @code{VALUE(8)}: @tab The milliseconds of the second + @end multitable + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + subroutine + + @item @emph{Syntax}: + @code{CALL DATE_AND_TIME([DATE, TIME, ZONE, VALUES])} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{DATE} @tab (Optional) The type shall be @code{CHARACTER(8)} or larger. + @item @var{TIME} @tab (Optional) The type shall be @code{CHARACTER(10)} or larger. + @item @var{ZONE} @tab (Optional) The type shall be @code{CHARACTER(5)} or larger. + @item @var{VALUES}@tab (Optional) The type shall be @code{INTEGER(8)}. + @end multitable + + @item @emph{Return value}: + None + + @item @emph{Example}: + @smallexample + program test_time_and_date + character(8) :: date + character(10) :: time + character(5) :: zone + integer,dimension(8) :: values + ! using keyword arguments + call date_and_time(date,time,zone,values) + call date_and_time(DATE=date,ZONE=zone) + call date_and_time(TIME=time) + call date_and_time(VALUES=values) + print '(a,2x,a,2x,a)', date, time, zone + print '(8i5))', values + end program test_time_and_date + @end smallexample + @end table + + + + @node DBLE + @section @code{DBLE} --- Double conversion function + @findex @code{DBLE} intrinsic + @cindex double conversion + + @table @asis + @item @emph{Description}: + @code{DBLE(X)} Converts @var{X} to double precision real type. + @code{DFLOAT} is an alias for @code{DBLE} + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{X = DBLE(X)} + @code{X = DFLOAT(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type shall be @code{INTEGER(*)}, @code{REAL(*)}, or @code{COMPLEX(*)}. + @end multitable + + @item @emph{Return value}: + The return value is of type double precision real. + + @item @emph{Example}: + @smallexample + program test_dble + real :: x = 2.18 + integer :: i = 5 + complex :: z = (2.3,1.14) + print *, dble(x), dble(i), dfloat(z) + end program test_dble + @end smallexample + @end table + + + + @node DCMPLX + @section @code{DCMPLX} --- Double complex conversion function + @findex @code{DCMPLX} intrinsic + @cindex DCMPLX + + @table @asis + @item @emph{Description}: + @code{DCMPLX(X [,Y])} returns a double complex number where @var{X} is + converted to the real component. If @var{Y} is present it is converted to the + imaginary component. If @var{Y} is not present then the imaginary component is + set to 0.0. If @var{X} is complex then @var{Y} must not be present. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{C = DCMPLX(X)} + @code{C = DCMPLX(X,Y)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type may be @code{INTEGER(*)}, @code{REAL(*)}, or @code{COMPLEX(*)}. + @item @var{Y} @tab Optional if @var{X} is not @code{COMPLEX(*)}. May be @code{INTEGER(*)} or @code{REAL(*)}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{COMPLEX(8)} + + @item @emph{Example}: + @smallexample + program test_dcmplx + integer :: i = 42 + real :: x = 3.14 + complex :: z + z = cmplx(i, x) + print *, dcmplx(i) + print *, dcmplx(x) + print *, dcmplx(z) + print *, dcmplx(x,i) + end program test_dcmplx + @end smallexample + @end table + + + + @node DFLOAT + @section @code{DFLOAT} --- Double conversion function + @findex @code{DFLOAT} intrinsic + @cindex double float conversion + + @table @asis + @item @emph{Description}: + @code{DFLOAT(X)} Converts @var{X} to double precision real type. + @code{DFLOAT} is an alias for @code{DBLE}. See @code{DBLE}. + @end table + + + + @node DIGITS + @section @code{DIGITS} --- Significant digits function + @findex @code{DIGITS} intrinsic + @cindex digits, significant + + @table @asis + @item @emph{Description}: + @code{DIGITS(X)} returns the number of significant digits of the internal model + representation of @var{X}. For example, on a system using a 32-bit + floating point representation, a default real number would likely return 24. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + inquiry function + + @item @emph{Syntax}: + @code{C = DIGITS(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type may be @code{INTEGER(*)} or @code{REAL(*)}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER}. + + @item @emph{Example}: + @smallexample + program test_digits + integer :: i = 12345 + real :: x = 3.143 + real(8) :: y = 2.33 + print *, digits(i) + print *, digits(x) + print *, digits(y) + end program test_digits + @end smallexample + @end table + + + + @node DIM + @section @code{DIM} --- Dim function + @findex @code{DIM} intrinsic + @findex @code{IDIM} intrinsic + @findex @code{DDIM} intrinsic + @cindex dim + + @table @asis + @item @emph{Description}: + @code{DIM(X,Y)} returns the difference @code{X-Y} if the result is positive; + otherwise returns zero. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{X = DIM(X,Y)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type shall be @code{INTEGER(*)} or @code{REAL(*)} + @item @var{Y} @tab The type shall be the same type and kind as @var{X}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER(*)} or @code{REAL(*)}. + + @item @emph{Example}: + @smallexample + program test_dim + integer :: i + real(8) :: x + i = dim(4, 15) + x = dim(4.345_8, 2.111_8) + print *, i + print *, x + end program test_dim + @end smallexample + + @item @emph{Specific names}: + @multitable @columnfractions .24 .24 .24 .24 + @item Name @tab Argument @tab Return type @tab Option + @item @code{IDIM(X,Y)} @tab @code{INTEGER(4) X,Y} @tab @code{INTEGER(4)} @tab gnu + @item @code{DDIM(X,Y)} @tab @code{REAL(8) X,Y} @tab @code{REAL(8)} @tab gnu + @end multitable + @end table + + + + @node DOT_PRODUCT + @section @code{DOT_PRODUCT} --- Dot product function + @findex @code{DOT_PRODUCT} intrinsic + @cindex Dot product + + @table @asis + @item @emph{Description}: + @code{DOT_PRODUCT(X,Y)} computes the dot product multiplication of two vectors + @var{X} and @var{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 + @code{INTEGER(*)} or @code{REAL(*)}, the result is @code{SUM(X*Y)}. If the + vectors are @code{COMPLEX(*)}, the result is @code{SUM(CONJG(X)*Y)}. If the + vectors are @code{LOGICAL}, the result is @code{ANY(X.AND.Y)}. + + @item @emph{Option}: + f95 + + @item @emph{Class}: + transformational function + + @item @emph{Syntax}: + @code{S = DOT_PRODUCT(X,Y)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type shall be numeric or @code{LOGICAL}, rank 1. + @item @var{Y} @tab The type shall be numeric or @code{LOGICAL}, rank 1. + @end multitable + + @item @emph{Return value}: + If the arguments are numeric, the return value is a scaler of numeric type, + @code{INTEGER(*)}, @code{REAL(*)}, or @code{COMPLEX(*)}. If the arguments are + @code{LOGICAL}, the return value is @code{.TRUE.} or @code{.FALSE.}. + + @item @emph{Example}: + @smallexample + program test_dot_prod + integer, dimension(3) :: a, b + a = (/ 1, 2, 3 /) + b = (/ 4, 5, 6 /) + print '(3i3)', a + print * + print '(3i3)', b + print * + print *, dot_product(a,b) + end program test_dot_prod + @end smallexample + @end table + + + + @node DPROD + @section @code{DPROD} --- Double product function + @findex @code{DPROD} intrinsic + @cindex Double product + + @table @asis + @item @emph{Description}: + @code{DPROD(X,Y)} returns the product @code{X*Y}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{D = DPROD(X,Y)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type shall be @code{REAL}. + @item @var{Y} @tab The type shall be @code{REAL}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{REAL(8)}. + + @item @emph{Example}: + @smallexample + program test_dprod + integer :: i + real :: x = 5.2 + real :: y = 2.3 + real(8) :: d + d = dprod(x,y) + print *, d + end program test_dprod + @end smallexample + @end table + + + + @node DREAL + @section @code{DREAL} --- Double real part function + @findex @code{DREAL} intrinsic + @cindex Double real part + + @table @asis + @item @emph{Description}: + @code{DREAL(Z)} returns the real part of complex variable @var{Z}. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{D = DREAL(Z)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{Z} @tab The type shall be @code{COMPLEX(8)}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{REAL(8)}. + + @item @emph{Example}: + @smallexample + program test_dreal + complex(8) :: z = (1.3_8,7.2_8) + print *, dreal(z) + end program test_dreal + @end smallexample + @end table + + + + @node DTIME + @section @code{DTIME} --- Execution time subroutine (or function) + @findex @code{DTIME} intrinsic + @cindex dtime subroutine + + @table @asis + @item @emph{Description}: + @code{DTIME(TARRAY, RESULT)} initially returns the number of seconds of runtime + since the start of the process's execution in @var{RESULT}. @var{TARRAY} + returns the user and system components of this time in @code{TARRAY(1)} and + @code{TARRAY(2)} respectively. @var{RESULT} is equal to @code{TARRAY(1) + + TARRAY(2)}. + + Subsequent invocations of @code{DTIME} return values accumulated since the + previous invocation. + + On some systems, the underlying timings are represented using types with + sufficiently small limits that overflows (wraparounds) are possible, such as + 32-bit types. Therefore, the values returned by this intrinsic might be, or + become, negative, or numerically less than previous values, during a single + run of the compiled program. + + If @code{DTIME} is invoked as a function, it can not be invoked as a + subroutine, and vice versa. + + @var{TARRAY} and @var{RESULT} are @code{INTENT(OUT)} and provide the following: + + @multitable @columnfractions .15 .30 .60 + @item @tab @code{TARRAY(1)}: @tab User time in seconds. + @item @tab @code{TARRAY(2)}: @tab System time in seconds. + @item @tab @code{RESULT}: @tab Run time since start in seconds. + @end multitable + + @item @emph{Option}: + gnu + + @item @emph{Class}: + subroutine + + @item @emph{Syntax}: + @multitable @columnfractions .80 + @item @code{CALL DTIME(TARRAY, RESULT)}. + @item @code{RESULT = DTIME(TARRAY)}, (not recommended). + @end multitable + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{TARRAY}@tab The type shall be @code{REAL, DIMENSION(2)}. + @item @var{RESULT}@tab The type shall be @code{REAL}. + @end multitable + + @item @emph{Return value}: + Elapsed time in seconds since the start of program execution. + + @item @emph{Example}: + @smallexample + program test_dtime + integer(8) :: i, j + real, dimension(2) :: tarray + real :: result + call dtime(tarray, result) + print *, result + print *, tarray(1) + print *, tarray(2) + do i=1,100000000 ! Just a delay + j = i * i - i + end do + call dtime(tarray, result) + print *, result + print *, tarray(1) + print *, tarray(2) + end program test_dtime + @end smallexample + @end table + + + + @node EOSHIFT + @section @code{EOSHIFT} --- End-off shift function + @findex @code{EOSHIFT} intrinsic + @cindex eoshift intrinsic + + @table @asis + @item @emph{Description}: + @code{EOSHIFT(ARRAY, SHIFT[,BOUNDARY, DIM])} performs an end-off shift on + elements of @var{ARRAY} along the dimension of @var{DIM}. If @var{DIM} is + omitted it is taken to be @code{1}. @var{DIM} is a scaler of type + @code{INTEGER} in the range of @math{1 /leq DIM /leq n)} where @math{n} is the + rank of @var{ARRAY}. If the rank of @var{ARRAY} is one, then all elements of + @var{ARRAY} are shifted by @var{SHIFT} places. If rank is greater than one, + then all complete rank one sections of @var{ARRAY} along the given dimension are + shifted. Elements shifted out one end of each rank one section are dropped. If + @var{BOUNDARY} is present then the corresponding value of from @var{BOUNDARY} + is copied back in the other end. If @var{BOUNDARY} is not present then the + following are copied in depending on the type of @var{ARRAY}. + + @multitable @columnfractions .15 .80 + @item @emph{Array Type} @tab @emph{Boundary Value} + @item Numeric @tab 0 of the type and kind of @var{ARRAY}. + @item Logical @tab @code{.FALSE.}. + @item Character(@var{len}) @tab @var{len} blanks. + @end multitable + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + transformational function + + @item @emph{Syntax}: + @code{A = EOSHIFT(A, SHIFT[,BOUNDARY, DIM])} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{ARRAY} @tab May be any type, not scaler. + @item @var{SHIFT} @tab The type shall be @code{INTEGER}. + @item @var{BOUNDARY} @tab Same type as @var{ARRAY}. + @item @var{DIM} @tab The type shall be @code{INTEGER}. + @end multitable + + @item @emph{Return value}: + Returns an array of same type and rank as the @var{ARRAY} argument. + + @item @emph{Example}: + @smallexample + program test_eoshift + integer, dimension(3,3) :: a + a = reshape( (/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /), (/ 3, 3 /)) + print '(3i3)', a(1,:) + print '(3i3)', a(2,:) + print '(3i3)', a(3,:) + a = EOSHIFT(a, SHIFT=(/1, 2, 1/), BOUNDARY=-5, DIM=2) + print * + print '(3i3)', a(1,:) + print '(3i3)', a(2,:) + print '(3i3)', a(3,:) + end program test_eoshift + @end smallexample + @end table + + + + @node EPSILON + @section @code{EPSILON} --- Epsilon function + @findex @code{EPSILON} intrinsic + @cindex epsilon, significant + + @table @asis + @item @emph{Description}: + @code{EPSILON(X)} returns a nearly negligible number relative to @code{1}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + inquiry function + + @item @emph{Syntax}: + @code{C = EPSILON(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type shall be @code{REAL(*)}. + @end multitable + + @item @emph{Return value}: + The return value is of same type as the argument. + + @item @emph{Example}: + @smallexample + program test_epsilon + real :: x = 3.143 + real(8) :: y = 2.33 + print *, EPSILON(x) + print *, EPSILON(y) + end program test_epsilon + @end smallexample + @end table + + + @node ERF @section @code{ERF} --- Error function @findex @code{ERF} intrinsic *************** end program test_erfc *** 1593,1598 **** --- 2433,2551 ---- + @node ETIME + @section @code{ETIME} --- Execution time subroutine (or function) + @findex @code{ETIME} intrinsic + @cindex ETIME subroutine + + @table @asis + @item @emph{Description}: + @code{ETIME(TARRAY, RESULT)} returns the number of seconds of runtime + since the start of the process's execution in @var{RESULT}. @var{TARRAY} + returns the user and system components of this time in @code{TARRAY(1)} and + @code{TARRAY(2)} respectively. @var{RESULT} is equal to @code{TARRAY(1) + TARRAY(2)}. + + On some systems, the underlying timings are represented using types with + sufficiently small limits that overflows (wraparounds) are possible, such as + 32-bit types. Therefore, the values returned by this intrinsic might be, or + become, negative, or numerically less than previous values, during a single + run of the compiled program. + + If @code{ETIME} is invoked as a function, it can not be invoked as a + subroutine, and vice versa. + + @var{TARRAY} and @var{RESULT} are @code{INTENT(OUT)} and provide the following: + + @multitable @columnfractions .15 .30 .60 + @item @tab @code{TARRAY(1)}: @tab User time in seconds. + @item @tab @code{TARRAY(2)}: @tab System time in seconds. + @item @tab @code{RESULT}: @tab Run time since start in seconds. + @end multitable + + @item @emph{Option}: + gnu + + @item @emph{Class}: + subroutine + + @item @emph{Syntax}: + @multitable @columnfractions .8 + @item @code{CALL ETIME(TARRAY, RESULT)}. + @item @code{RESULT = ETIME(TARRAY)}, (not recommended). + @end multitable + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{TARRAY}@tab The type shall be @code{REAL, DIMENSION(2)}. + @item @var{RESULT}@tab The type shall be @code{REAL}. + @end multitable + + @item @emph{Return value}: + Elapsed time in seconds since the start of program execution. + + @item @emph{Example}: + @smallexample + program test_etime + integer(8) :: i, j + real, dimension(2) :: tarray + real :: result + call ETIME(tarray, result) + print *, result + print *, tarray(1) + print *, tarray(2) + do i=1,100000000 ! Just a delay + j = i * i - i + end do + call ETIME(tarray, result) + print *, result + print *, tarray(1) + print *, tarray(2) + end program test_etime + @end smallexample + @end table + + + + @node EXIT + @section @code{EXIT} --- Exit the program with status. + @findex @code{EXIT} + @cindex exit + + @table @asis + @item @emph{Description}: + @code{EXIT} causes immediate termination of the program with status. If status + is omitted it returns the canonical @emph{success} for the system. All Fortran + I/O units are closed. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + non-elemental subroutine + + @item @emph{Syntax}: + @code{CALL EXIT([STATUS])} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{STATUS} @tab The type of the argument shall be @code{INTEGER(*)}. + @end multitable + + @item @emph{Return value}: + @code{STATUS} is passed to the parent process on exit. + + @item @emph{Example}: + @smallexample + program test_exit + integer :: STATUS = 0 + print *, 'This program is going to exit.' + call EXIT(STATUS) + end program test_exit + @end smallexample + @end table + + + @node EXP @section @code{EXP} --- Exponential function @findex @code{EXP} intrinsic *************** end program test_exp *** 1643,1648 **** --- 2596,2723 ---- + @node EXPONENT + @section @code{EXPONENT} --- Exponent function + @findex @code{EXPONENT} intrinsic + @cindex exponent function + + @table @asis + @item @emph{Description}: + @code{EXPONENT(X)} returns the value of the exponent part of @var{X}. If @var{X} + is zero the value returned is zero. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{I = EXPONENT(X)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type shall be @code{REAL(*)}. + @end multitable + + @item @emph{Return value}: + The return value is of type default @code{INTEGER}. + + @item @emph{Example}: + @smallexample + program test_exponent + real :: x = 1.0 + integer :: i + i = exponent(x) + print *, i + print *, exponent(0.0) + end program test_exponent + @end smallexample + @end table + + + + @node FLOOR + @section @code{FLOOR} --- Integer floor function + @findex @code{FLOOR} intrinsic + @cindex floor + + @table @asis + @item @emph{Description}: + @code{FLOOR(X)} returns the greatest integer less than or equal to @var{X}. + + @item @emph{Option}: + f95, gnu + + @item @emph{Class}: + elemental function + + @item @emph{Syntax}: + @code{I = FLOOR(X[,KIND])} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{X} @tab The type shall be @code{REAL(*)}. + @item @var{KIND} @tab Optional scaler integer initialization expression. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER(KIND)} + + @item @emph{Example}: + @smallexample + program test_floor + real :: x = 63.29 + real :: y = -63.59 + print *, floor(x) ! returns 63 + print *, floor(y) ! returns -64 + end program test_floor + @end smallexample + @end table + + + + @node FNUM + @section @code{FNUM} --- File number function + @findex @code{FNUM} intrinsic + @cindex fnum + + @table @asis + @item @emph{Description}: + @code{FNUM(UNIT)} returns the Posix file descriptor number coresponding to the + open Fortran I/O unit @code{UNIT}. + + @item @emph{Option}: + gnu + + @item @emph{Class}: + non-elemental function + + @item @emph{Syntax}: + @code{I = FNUM(UNIT)} + + @item @emph{Arguments}: + @multitable @columnfractions .15 .80 + @item @var{UNIT} @tab The type shall be @code{INTEGER}. + @end multitable + + @item @emph{Return value}: + The return value is of type @code{INTEGER} + + @item @emph{Example}: + @smallexample + program test_fnum + integer :: i + open (unit=10, status = "scratch") + i = fnum(10) + print *, i + close (10) + end program test_fnum + @end smallexample + @end table + + + @node LOG @section @code{LOG} --- Logarithm function @findex @code{LOG} intrinsic *************** end program test_tanh *** 1985,2039 **** - @comment gen command_argument_count - @comment - @comment gen conjg - @comment dconjg - @comment - @comment gen count - @comment - @comment sub cpu_time - @comment - @comment gen cshift - @comment - @comment sub date_and_time - @comment - @comment gen dble - @comment dfloat - @comment - @comment gen dcmplx - @comment - @comment gen digits - @comment - @comment gen dim - @comment idim - @comment ddim - @comment - @comment gen dot_product - @comment - @comment gen dprod - @comment - @comment gen dreal - @comment - @comment sub dtime - @comment - @comment gen eoshift - @comment - @comment gen epsilon - @comment - @comment gen etime - @comment sub etime - @comment - @comment sub exit - @comment - @comment gen exponent - @comment - @comment gen floor - @comment @comment sub flush @comment - @comment gen fnum - @comment @comment gen fraction @comment @comment gen fstat --- 3060,3067 ---- diff -Nrcpad gcc-4.0.1/gcc/fortran/invoke.texi gcc-4.0.2/gcc/fortran/invoke.texi *** gcc-4.0.1/gcc/fortran/invoke.texi Mon Jun 20 20:16:55 2005 --- gcc-4.0.2/gcc/fortran/invoke.texi Wed Aug 31 12:39:27 2005 *************** by type. Explanations are in the follow *** 156,162 **** @item Code Generation Options @xref{Code Gen Options,,Options for Code Generation Conventions}. @gccoptlist{ ! -ff2c -fno-underscoring -fsecond-underscore @gol -fbounds-check -fmax-stack-var-size=@var{n} @gol -fpackderived -frepack-arrays} @end table --- 156,162 ---- @item Code Generation Options @xref{Code Gen Options,,Options for Code Generation Conventions}. @gccoptlist{ ! -fno-automatic -ff2c -fno-underscoring -fsecond-underscore @gol -fbounds-check -fmax-stack-var-size=@var{n} @gol -fpackderived -frepack-arrays} @end table *************** Specify that no implicit typing is allow *** 270,276 **** @cindex option, -std=@var{std} @item -std=@var{std} Conform to the specified standard. Allowed values for @var{std} are ! @samp{gnu} and @samp{f95}. @end table --- 270,276 ---- @cindex option, -std=@var{std} @item -std=@var{std} Conform to the specified standard. Allowed values for @var{std} are ! @samp{gnu}, @samp{f95}, @samp{f2003} and @samp{legacy}. @end table *************** one of the forms is listed---the one whi *** 528,535 **** can figure out the other form by either removing @option{no-} or adding it. - @table @gcctabopt @cindex @option{-ff2c} option @cindex options, @option{-ff2c} @item -ff2c --- 528,544 ---- can figure out the other form by either removing @option{no-} or adding it. @table @gcctabopt + @cindex @option{-fno-automatic} option + @cindex options, @option{-fno-automatic} + @item -fno-automatic + @cindex SAVE statement + @cindex statements, SAVE + Treat each program unit as if the @code{SAVE} statement was specified for + every local variable and array referenced in it. Does not affect common + blocks. (Some Fortran compilers provide this option under the name + @option{-static}.) + @cindex @option{-ff2c} option @cindex options, @option{-ff2c} @item -ff2c diff -Nrcpad gcc-4.0.1/gcc/fortran/io.c gcc-4.0.2/gcc/fortran/io.c *** gcc-4.0.1/gcc/fortran/io.c Wed Jun 1 03:30:19 2005 --- gcc-4.0.2/gcc/fortran/io.c Fri Sep 9 19:48:14 2005 *************** check_format (void) *** 433,438 **** --- 433,439 ---- format_item: /* In this state, the next thing has to be a format item. */ t = format_lex (); + format_item_1: switch (t) { case FMT_POSINT: *************** between_desc: *** 705,712 **** goto syntax; default: ! error = "Missing comma"; ! goto syntax; } optional_comma: --- 706,715 ---- goto syntax; default: ! if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C") ! == FAILURE) ! return FAILURE; ! goto format_item_1; } optional_comma: *************** resolve_tag (const io_tag * tag, gfc_exp *** 966,998 **** if (gfc_resolve_expr (e) == FAILURE) return FAILURE; ! if (e->ts.type != tag->type) { ! /* Format label can be integer varibale. */ ! if (tag != &tag_format || e->ts.type != BT_INTEGER) ! { ! gfc_error ("%s tag at %L must be of type %s or %s", tag->name, ! &e->where, gfc_basic_typename (tag->type), ! gfc_basic_typename (BT_INTEGER)); ! return FAILURE; ! } } if (tag == &tag_format) { ! if (e->rank != 1 && e->rank != 0) { ! gfc_error ("FORMAT tag at %L cannot be array of strings", ! &e->where); ! return FAILURE; } ! /* Check assigned label. */ ! if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_INTEGER ! && e->symtree->n.sym->attr.assign != 1) { ! gfc_error ("Variable '%s' has not been assigned a format label at %L", ! e->symtree->n.sym->name, &e->where); ! return FAILURE; } } else --- 969,1031 ---- if (gfc_resolve_expr (e) == FAILURE) return FAILURE; ! if (e->ts.type != tag->type && tag != &tag_format) { ! gfc_error ("%s tag at %L must be of type %s", tag->name, ! &e->where, gfc_basic_typename (tag->type)); ! return FAILURE; } if (tag == &tag_format) { ! /* If e's rank is zero and e is not an element of an array, it should be ! of integer or character type. The integer variable should be ! ASSIGNED. */ ! if (e->symtree == NULL || e->symtree->n.sym->as == NULL ! || e->symtree->n.sym->as->rank == 0) { ! if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER) ! { ! gfc_error ("%s tag at %L must be of type %s or %s", tag->name, ! &e->where, gfc_basic_typename (BT_CHARACTER), ! gfc_basic_typename (BT_INTEGER)); ! return FAILURE; ! } ! else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE) ! { ! if (gfc_notify_std (GFC_STD_F95_DEL, ! "Obsolete: ASSIGNED variable in FORMAT tag at %L", ! &e->where) == FAILURE) ! return FAILURE; ! if (e->symtree->n.sym->attr.assign != 1) ! { ! gfc_error ("Variable '%s' at %L has not been assigned a " ! "format label", e->symtree->n.sym->name, &e->where); ! return FAILURE; ! } ! } ! return SUCCESS; } ! else { ! /* if rank is nonzero, we allow the type to be character under ! GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be ! assigned an Hollerith constant. */ ! if (e->ts.type == BT_CHARACTER) ! { ! if (gfc_notify_std (GFC_STD_GNU, ! "Extension: Character array in FORMAT tag at %L", ! &e->where) == FAILURE) ! return FAILURE; ! } ! else ! { ! if (gfc_notify_std (GFC_STD_LEGACY, ! "Extension: Non-character in FORMAT tag at %L", ! &e->where) == FAILURE) ! return FAILURE; ! } ! return SUCCESS; } } else *************** gfc_resolve_filepos (gfc_filepos * fp) *** 1406,1411 **** --- 1439,1445 ---- { RESOLVE_TAG (&tag_unit, fp->unit); + RESOLVE_TAG (&tag_iostat, fp->iostat); if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE) return FAILURE; *************** match_dt_element (io_kind k, gfc_dt * dt *** 1640,1646 **** m = match_ltag (&tag_end, &dt->end); if (m == MATCH_YES) ! dt->end_where = gfc_current_locus; if (m != MATCH_NO) return m; --- 1674,1687 ---- m = match_ltag (&tag_end, &dt->end); if (m == MATCH_YES) ! { ! if (k == M_WRITE) ! { ! gfc_error ("END tag at %C not allowed in output statement"); ! return MATCH_ERROR; ! } ! dt->end_where = gfc_current_locus; ! } if (m != MATCH_NO) return m; *************** match_io (io_kind k) *** 2087,2092 **** --- 2128,2163 ---- { if (k == M_WRITE) goto syntax; + else if (k == M_PRINT + && (gfc_current_form == FORM_FIXED + || gfc_peek_char () == ' ')) + { + /* Treat the non-standard case of PRINT namelist. */ + where = gfc_current_locus; + if ((gfc_match_name (name) == MATCH_YES) + && !gfc_find_symbol (name, NULL, 1, &sym) + && sym->attr.flavor == FL_NAMELIST) + { + if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at " + "%C is an extension") == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + if (gfc_match_eos () == MATCH_NO) + { + gfc_error ("Namelist followed by I/O list at %C"); + m = MATCH_ERROR; + goto cleanup; + } + + dt->io_unit = default_unit (k); + dt->namelist = sym; + goto get_io_list; + } + else + gfc_current_locus = where; + } if (gfc_current_form == FORM_FREE) { diff -Nrcpad gcc-4.0.1/gcc/fortran/iresolve.c gcc-4.0.2/gcc/fortran/iresolve.c *** gcc-4.0.1/gcc/fortran/iresolve.c Thu May 19 22:06:42 2005 --- gcc-4.0.2/gcc/fortran/iresolve.c Wed Aug 10 20:24:50 2005 *************** gfc_resolve_all (gfc_expr * f, gfc_expr *** 120,126 **** if (dim != NULL) { ! gfc_resolve_index (dim, 1); f->rank = mask->rank - 1; f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); } --- 120,126 ---- if (dim != NULL) { ! gfc_resolve_dim_arg (dim); f->rank = mask->rank - 1; f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); } *************** gfc_resolve_any (gfc_expr * f, gfc_expr *** 158,164 **** if (dim != NULL) { ! gfc_resolve_index (dim, 1); f->rank = mask->rank - 1; f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); } --- 158,164 ---- if (dim != NULL) { ! gfc_resolve_dim_arg (dim); f->rank = mask->rank - 1; f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); } *************** gfc_resolve_count (gfc_expr * f, gfc_exp *** 336,342 **** if (dim != NULL) { f->rank = mask->rank - 1; ! gfc_resolve_index (dim, 1); f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); } --- 336,342 ---- if (dim != NULL) { f->rank = mask->rank - 1; ! gfc_resolve_dim_arg (dim); f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); } *************** gfc_resolve_cshift (gfc_expr * f, gfc_ex *** 362,370 **** else n = 0; if (dim != NULL) { ! gfc_resolve_index (dim, 1); /* Convert dim to shift's kind, so we don't need so many variations. */ if (dim->ts.kind != shift->ts.kind) gfc_convert_type_warn (dim, &shift->ts, 2, 0); --- 362,380 ---- else n = 0; + /* Convert shift to at least gfc_default_integer_kind, so we don't need + kind=1 and kind=2 versions of the library functions. */ + if (shift->ts.kind < gfc_default_integer_kind) + { + gfc_typespec ts; + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + gfc_convert_type_warn (shift, &ts, 2, 0); + } + if (dim != NULL) { ! gfc_resolve_dim_arg (dim); /* Convert dim to shift's kind, so we don't need so many variations. */ if (dim->ts.kind != shift->ts.kind) gfc_convert_type_warn (dim, &shift->ts, 2, 0); *************** gfc_resolve_eoshift (gfc_expr * f, gfc_e *** 451,460 **** if (boundary && boundary->rank > 0) n = n | 2; ! /* Convert dim to the same type as shift, so we don't need quite so many ! variations. */ ! if (dim != NULL && dim->ts.kind != shift->ts.kind) ! gfc_convert_type_warn (dim, &shift->ts, 2, 0); f->value.function.name = gfc_get_string (PREFIX("eoshift%d_%d"), n, shift->ts.kind); --- 461,483 ---- if (boundary && boundary->rank > 0) n = n | 2; ! /* Convert shift to at least gfc_default_integer_kind, so we don't need ! kind=1 and kind=2 versions of the library functions. */ ! if (shift->ts.kind < gfc_default_integer_kind) ! { ! gfc_typespec ts; ! ts.type = BT_INTEGER; ! ts.kind = gfc_default_integer_kind; ! gfc_convert_type_warn (shift, &ts, 2, 0); ! } ! ! if (dim != NULL) ! { ! gfc_resolve_dim_arg (dim); ! /* Convert dim to shift's kind, so we don't need so many variations. */ ! if (dim->ts.kind != shift->ts.kind) ! gfc_convert_type_warn (dim, &shift->ts, 2, 0); ! } f->value.function.name = gfc_get_string (PREFIX("eoshift%d_%d"), n, shift->ts.kind); *************** gfc_resolve_int (gfc_expr * f, gfc_expr *** 689,694 **** --- 712,737 ---- void + gfc_resolve_isatty (gfc_expr * f, gfc_expr * u) + { + gfc_typespec ts; + + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_integer_kind; + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.derived = NULL; + ts.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX("isatty_l%d"), f->ts.kind); + } + + + void gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift) { f->ts = i->ts; *************** gfc_resolve_maxloc (gfc_expr * f, gfc_ex *** 878,884 **** else { f->rank = array->rank - 1; ! gfc_resolve_index (dim, 1); } name = mask ? "mmaxloc" : "maxloc"; --- 921,927 ---- else { f->rank = array->rank - 1; ! gfc_resolve_dim_arg (dim); } name = mask ? "mmaxloc" : "maxloc"; *************** gfc_resolve_maxval (gfc_expr * f, gfc_ex *** 897,903 **** if (dim != NULL) { f->rank = array->rank - 1; ! gfc_resolve_index (dim, 1); } f->value.function.name = --- 940,946 ---- if (dim != NULL) { f->rank = array->rank - 1; ! gfc_resolve_dim_arg (dim); } f->value.function.name = *************** gfc_resolve_minloc (gfc_expr * f, gfc_ex *** 939,945 **** else { f->rank = array->rank - 1; ! gfc_resolve_index (dim, 1); } name = mask ? "mminloc" : "minloc"; --- 982,988 ---- else { f->rank = array->rank - 1; ! gfc_resolve_dim_arg (dim); } name = mask ? "mminloc" : "minloc"; *************** gfc_resolve_minval (gfc_expr * f, gfc_ex *** 958,964 **** if (dim != NULL) { f->rank = array->rank - 1; ! gfc_resolve_index (dim, 1); } f->value.function.name = --- 1001,1007 ---- if (dim != NULL) { f->rank = array->rank - 1; ! gfc_resolve_dim_arg (dim); } f->value.function.name = *************** gfc_resolve_product (gfc_expr * f, gfc_e *** 1055,1061 **** if (dim != NULL) { f->rank = array->rank - 1; ! gfc_resolve_index (dim, 1); } f->value.function.name = --- 1098,1104 ---- if (dim != NULL) { f->rank = array->rank - 1; ! gfc_resolve_dim_arg (dim); } f->value.function.name = *************** gfc_resolve_spread (gfc_expr * f, gfc_ex *** 1298,1304 **** f->rank = source->rank + 1; f->value.function.name = PREFIX("spread"); ! gfc_resolve_index (dim, 1); gfc_resolve_index (ncopies, 1); } --- 1341,1347 ---- f->rank = source->rank + 1; f->value.function.name = PREFIX("spread"); ! gfc_resolve_dim_arg (dim); gfc_resolve_index (ncopies, 1); } *************** gfc_resolve_sum (gfc_expr * f, gfc_expr *** 1345,1351 **** if (dim != NULL) { f->rank = array->rank - 1; ! gfc_resolve_index (dim, 1); } f->value.function.name = --- 1388,1394 ---- if (dim != NULL) { f->rank = array->rank - 1; ! gfc_resolve_dim_arg (dim); } f->value.function.name = *************** gfc_resolve_fstat_sub (gfc_code * c) *** 1916,1921 **** --- 1959,1983 ---- c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } + + void + gfc_resolve_ttynam_sub (gfc_code * c) + { + gfc_typespec ts; + + if (c->ext.actual->expr->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.derived = NULL; + ts.cl = NULL; + gfc_convert_type (c->ext.actual->expr, &ts, 2); + } + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub")); + } + + /* Resolve the UMASK intrinsic subroutine. */ void diff -Nrcpad gcc-4.0.1/gcc/fortran/lang.opt gcc-4.0.2/gcc/fortran/lang.opt *** gcc-4.0.1/gcc/fortran/lang.opt Mon Jun 20 20:16:55 2005 --- gcc-4.0.2/gcc/fortran/lang.opt Wed Aug 31 12:39:27 2005 *************** fdollar-ok *** 85,90 **** --- 85,94 ---- F95 Allow dollar signs in entity names + fautomatic + F95 + Do not treat local variables and COMMON blocks as if they were named in SAVE statements + fbackslash F95 Specify that backslash in string introduces an escape character *************** std=gnu *** 165,168 **** --- 169,176 ---- F95 Conform nothing in particular. + std=legacy + F95 + Accept extensions to support legacy code. + ; This comment is to ensure we retain the blank line above. diff -Nrcpad gcc-4.0.1/gcc/fortran/match.c gcc-4.0.2/gcc/fortran/match.c *** gcc-4.0.1/gcc/fortran/match.c Sat Jun 18 21:22:05 2005 --- gcc-4.0.2/gcc/fortran/match.c Fri Sep 9 09:05:52 2005 *************** match *** 250,256 **** gfc_match_label (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_state_data *p; match m; gfc_new_block = NULL; --- 250,255 ---- *************** gfc_match_label (void) *** 265,282 **** return MATCH_ERROR; } ! if (gfc_new_block->attr.flavor != FL_LABEL ! && gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, ! gfc_new_block->name, NULL) == FAILURE) ! return MATCH_ERROR; ! for (p = gfc_state_stack; p; p = p->previous) ! if (p->sym == gfc_new_block) ! { ! gfc_error ("Label %s at %C already in use by a parent block", ! gfc_new_block->name); ! return MATCH_ERROR; ! } return MATCH_YES; } --- 264,278 ---- return MATCH_ERROR; } ! if (gfc_new_block->attr.flavor == FL_LABEL) ! { ! gfc_error ("Duplicate construct label '%s' at %C", name); ! return MATCH_ERROR; ! } ! if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, ! gfc_new_block->name, NULL) == FAILURE) ! return MATCH_ERROR; return MATCH_YES; } *************** match_common_name (char *name) *** 2233,2242 **** match gfc_match_common (void) { ! gfc_symbol *sym, **head, *tail, *old_blank_common; char name[GFC_MAX_SYMBOL_LEN+1]; gfc_common_head *t; gfc_array_spec *as; match m; old_blank_common = gfc_current_ns->blank_common.head; --- 2229,2239 ---- match gfc_match_common (void) { ! gfc_symbol *sym, **head, *tail, *other, *old_blank_common; char name[GFC_MAX_SYMBOL_LEN+1]; gfc_common_head *t; gfc_array_spec *as; + gfc_equiv * e1, * e2; match m; old_blank_common = gfc_current_ns->blank_common.head; *************** gfc_match_common (void) *** 2248,2256 **** as = NULL; - if (gfc_match_eos () == MATCH_YES) - goto syntax; - for (;;) { m = match_common_name (name); --- 2245,2250 ---- *************** gfc_match_common (void) *** 2280,2288 **** } /* Grab the list of symbols. */ - if (gfc_match_eos () == MATCH_YES) - goto done; - for (;;) { m = gfc_match_symbol (&sym, 0); --- 2274,2279 ---- *************** gfc_match_common (void) *** 2361,2368 **** --- 2352,2397 ---- sym->as = as; as = NULL; + } + sym->common_head = t; + + /* Check to see if the symbol is already in an equivalence group. + If it is, set the other members as being in common. */ + if (sym->attr.in_equivalence) + { + for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) + { + for (e2 = e1; e2; e2 = e2->eq) + if (e2->expr->symtree->n.sym == sym) + goto equiv_found; + + continue; + + equiv_found: + + for (e2 = e1; e2; e2 = e2->eq) + { + other = e2->expr->symtree->n.sym; + if (other->common_head + && other->common_head != sym->common_head) + { + gfc_error ("Symbol '%s', in COMMON block '%s' at " + "%C is being indirectly equivalenced to " + "another COMMON block '%s'", + sym->name, + sym->common_head->name, + other->common_head->name); + goto cleanup; + } + other->attr.in_common = 1; + other->common_head = t; + } + } + } + + gfc_gobble_whitespace (); if (gfc_match_eos () == MATCH_YES) goto done; *************** gfc_match_equivalence (void) *** 2566,2572 **** --- 2595,2604 ---- { gfc_equiv *eq, *set, *tail; gfc_ref *ref; + gfc_symbol *sym; match m; + gfc_common_head *common_head = NULL; + bool common_flag; tail = NULL; *************** gfc_match_equivalence (void) *** 2583,2592 **** goto syntax; set = eq; for (;;) { ! m = gfc_match_variable (&set->expr, 1); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) --- 2615,2625 ---- goto syntax; set = eq; + common_flag = FALSE; for (;;) { ! m = gfc_match_equiv_variable (&set->expr); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) *************** gfc_match_equivalence (void) *** 2601,2606 **** --- 2634,2647 ---- goto cleanup; } + if (set->expr->symtree->n.sym->attr.in_common) + { + common_flag = TRUE; + common_head = set->expr->symtree->n.sym->common_head; + } + + set->expr->symtree->n.sym->attr.in_equivalence = 1; + if (gfc_match_char (')') == MATCH_YES) break; if (gfc_match_char (',') != MATCH_YES) *************** gfc_match_equivalence (void) *** 2610,2615 **** --- 2651,2676 ---- set = set->eq; } + /* If one of the members of an equivalence is in common, then + mark them all as being in common. Before doing this, check + that members of the equivalence group are not in different + common blocks. */ + if (common_flag) + for (set = eq; set; set = set->eq) + { + sym = set->expr->symtree->n.sym; + if (sym->common_head && sym->common_head != common_head) + { + gfc_error ("Attempt to indirectly overlap COMMON " + "blocks %s and %s by EQUIVALENCE at %C", + sym->common_head->name, + common_head->name); + goto cleanup; + } + sym->attr.in_common = 1; + sym->common_head = common_head; + } + if (gfc_match_eos () == MATCH_YES) break; if (gfc_match_char (',') != MATCH_YES) *************** gfc_match_st_function (void) *** 2660,2665 **** --- 2721,2728 ---- m = gfc_match (" = %e%t", &expr); if (m == MATCH_NO) goto undo_error; + + gfc_free_error (&old_error); if (m == MATCH_ERROR) return m; diff -Nrcpad gcc-4.0.1/gcc/fortran/match.h gcc-4.0.2/gcc/fortran/match.h *** gcc-4.0.1/gcc/fortran/match.h Tue Apr 5 09:03:35 2005 --- gcc-4.0.2/gcc/fortran/match.h Fri Sep 9 09:05:52 2005 *************** match gfc_match_target (void); *** 129,134 **** --- 129,135 ---- match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **); match gfc_match_rvalue (gfc_expr **); match gfc_match_variable (gfc_expr **, int); + match gfc_match_equiv_variable (gfc_expr **); match gfc_match_actual_arglist (int, gfc_actual_arglist **); match gfc_match_literal_constant (gfc_expr **, int); diff -Nrcpad gcc-4.0.1/gcc/fortran/misc.c gcc-4.0.2/gcc/fortran/misc.c *** gcc-4.0.1/gcc/fortran/misc.c Tue Jan 18 12:11:53 2005 --- gcc-4.0.2/gcc/fortran/misc.c Tue Jul 12 01:50:48 2005 *************** gfc_basic_typename (bt type) *** 159,164 **** --- 159,167 ---- case BT_CHARACTER: p = "CHARACTER"; break; + case BT_HOLLERITH: + p = "HOLLERITH"; + break; case BT_DERIVED: p = "DERIVED"; break; *************** gfc_typename (gfc_typespec * ts) *** 207,212 **** --- 210,218 ---- case BT_CHARACTER: sprintf (buffer, "CHARACTER(%d)", ts->kind); break; + case BT_HOLLERITH: + sprintf (buffer, "HOLLERITH"); + break; case BT_DERIVED: sprintf (buffer, "TYPE(%s)", ts->derived->name); break; diff -Nrcpad gcc-4.0.1/gcc/fortran/module.c gcc-4.0.2/gcc/fortran/module.c *** gcc-4.0.1/gcc/fortran/module.c Thu Feb 24 18:26:26 2005 --- gcc-4.0.2/gcc/fortran/module.c Fri Sep 9 09:05:53 2005 *************** for more details. *** 18,25 **** You should have received a copy of the GNU General Public License along with GCC; see the file COPYING. If not, write to the Free ! Software Foundation, 59 Temple Place - Suite 330, Boston, MA ! 02111-1307, USA. */ /* The syntax of gfortran modules resembles that of lisp lists, ie a sequence of atoms, which can be left or right parenthesis, names, --- 18,25 ---- You should have received a copy of the GNU General Public License along with GCC; see the file COPYING. If not, write to the Free ! Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA ! 02110-1301, USA. */ /* The syntax of gfortran modules resembles that of lisp lists, ie a sequence of atoms, which can be left or right parenthesis, names, *************** Software Foundation, 59 Temple Place - S *** 47,52 **** --- 47,55 ---- ( ( ) ... ) + + ( equivalence list ) + ( *************** syntax: *** 582,601 **** cleanup: free_rename (); return MATCH_ERROR; ! } ! /* Given a name, return the name under which to load this symbol. ! Returns NULL if this symbol shouldn't be loaded. */ static const char * ! find_use_name (const char *name) { gfc_use_rename *u; for (u = gfc_rename_list; u; u = u->next) ! if (strcmp (u->use_name, name) == 0) ! break; if (u == NULL) return only_flag ? NULL : name; --- 585,618 ---- cleanup: free_rename (); return MATCH_ERROR; ! } ! /* Given a name and a number, inst, return the inst name ! under which to load this symbol. Returns NULL if this ! symbol shouldn't be loaded. If inst is zero, returns ! the number of instances of this name. */ static const char * ! find_use_name_n (const char *name, int *inst) { gfc_use_rename *u; + int i; + i = 0; for (u = gfc_rename_list; u; u = u->next) ! { ! if (strcmp (u->use_name, name) != 0) ! continue; ! if (++i == *inst) ! break; ! } ! ! if (!*inst) ! { ! *inst = i; ! return NULL; ! } if (u == NULL) return only_flag ? NULL : name; *************** find_use_name (const char *name) *** 605,610 **** --- 622,649 ---- return (u->local_name[0] != '\0') ? u->local_name : name; } + /* Given a name, return the name under which to load this symbol. + Returns NULL if this symbol shouldn't be loaded. */ + + static const char * + find_use_name (const char *name) + { + int i = 1; + return find_use_name_n (name, &i); + } + + /* Given a real name, return the number of use names associated + with it. */ + + static int + number_use_names (const char *name) + { + int i = 0; + const char *c; + c = find_use_name_n (name, &i); + return i; + } + /* Try to find the operator in the current list. */ *************** mio_name (int t, const mstring * m) *** 1280,1286 **** return t; } ! /* Specialisation of mio_name. */ #define DECL_MIO_NAME(TYPE) \ static inline TYPE \ --- 1319,1325 ---- return t; } ! /* Specialization of mio_name. */ #define DECL_MIO_NAME(TYPE) \ static inline TYPE \ *************** static const mstring attr_bits[] = *** 1424,1430 **** minit (NULL, -1) }; ! /* Specialisation of mio_name. */ DECL_MIO_NAME(ab_attribute) DECL_MIO_NAME(ar_type) DECL_MIO_NAME(array_type) --- 1463,1469 ---- minit (NULL, -1) }; ! /* Specialization of mio_name. */ DECL_MIO_NAME(ab_attribute) DECL_MIO_NAME(ar_type) DECL_MIO_NAME(array_type) *************** mio_expr (gfc_expr ** ep) *** 2564,2569 **** --- 2603,2657 ---- } + /* Read and write namelists */ + + static void + mio_namelist (gfc_symbol * sym) + { + gfc_namelist *n, *m; + const char *check_name; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (n = sym->namelist; n; n = n->next) + mio_symbol_ref (&n->sym); + } + else + { + /* This departure from the standard is flagged as an error. + It does, in fact, work correctly. TODO: Allow it + conditionally? */ + if (sym->attr.flavor == FL_NAMELIST) + { + check_name = find_use_name (sym->name); + if (check_name && strcmp (check_name, sym->name) != 0) + gfc_error("Namelist %s cannot be renamed by USE" + " association to %s.", + sym->name, check_name); + } + + m = NULL; + while (peek_atom () != ATOM_RPAREN) + { + n = gfc_get_namelist (); + mio_symbol_ref (&n->sym); + + if (sym->namelist == NULL) + sym->namelist = n; + else + m->next = n; + + m = n; + } + sym->namelist_tail = m; + } + + mio_rparen (); + } + + /* Save/restore lists of gfc_interface stuctures. When loading an interface, we are really appending to the existing list of interfaces. Checking for duplicate and ambiguous interfaces has to *************** mio_symbol (gfc_symbol * sym) *** 2724,2729 **** --- 2812,2818 ---- sym->component_access = MIO_NAME(gfc_access) (sym->component_access, access_types); + mio_namelist (sym); mio_rparen (); } *************** load_commons(void) *** 2870,2875 **** --- 2959,3006 ---- mio_rparen(); } + /* load_equiv()-- Load equivalences. */ + + static void + load_equiv(void) + { + gfc_equiv *head, *tail, *end; + + mio_lparen(); + + end = gfc_current_ns->equiv; + while(end != NULL && end->next != NULL) + end = end->next; + + while(peek_atom() != ATOM_RPAREN) { + mio_lparen(); + head = tail = NULL; + + while(peek_atom() != ATOM_RPAREN) + { + if (head == NULL) + head = tail = gfc_get_equiv(); + else + { + tail->eq = gfc_get_equiv(); + tail = tail->eq; + } + + mio_pool_string(&tail->module); + mio_expr(&tail->expr); + } + + if (end == NULL) + gfc_current_ns->equiv = head; + else + end->next = head; + + end = head; + mio_rparen(); + } + + mio_rparen(); + } /* Recursive function to traverse the pointer_info tree and load a needed symbol. We return nonzero if we load a symbol and stop the *************** read_module (void) *** 2970,2976 **** const char *p; char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_intrinsic_op i; ! int ambiguous, symbol; pointer_info *info; gfc_use_rename *u; gfc_symtree *st; --- 3101,3107 ---- const char *p; char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_intrinsic_op i; ! int ambiguous, symbol, j, nuse; pointer_info *info; gfc_use_rename *u; gfc_symtree *st; *************** read_module (void) *** 2982,2987 **** --- 3113,3121 ---- get_module_locus (&user_operators); skip_list (); skip_list (); + + /* Skip commons and equivalences for now. */ + skip_list (); skip_list (); mio_lparen (); *************** read_module (void) *** 3034,3083 **** info = get_integer (symbol); ! /* Get the local name for this symbol. */ ! p = find_use_name (name); ! ! /* Skip symtree nodes not in an ONLY caluse. */ ! if (p == NULL) ! continue; ! ! /* Check for ambiguous symbols. */ ! st = gfc_find_symtree (gfc_current_ns->sym_root, p); ! if (st != NULL) ! { ! if (st->n.sym != info->u.rsym.sym) ! st->ambiguous = 1; ! info->u.rsym.symtree = st; ! } ! else { ! /* Create a symtree node in the current namespace for this symbol. */ ! st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) : ! gfc_new_symtree (&gfc_current_ns->sym_root, p); ! st->ambiguous = ambiguous; ! sym = info->u.rsym.sym; ! /* Create a symbol node if it doesn't already exist. */ ! if (sym == NULL) { ! sym = info->u.rsym.sym = ! gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns); ! ! sym->module = gfc_get_string (info->u.rsym.module); } ! st->n.sym = sym; ! st->n.sym->refs++; ! /* Store the symtree pointing to this symbol. */ ! info->u.rsym.symtree = st; ! if (info->u.rsym.state == UNUSED) ! info->u.rsym.state = NEEDED; ! info->u.rsym.referenced = 1; } } --- 3168,3227 ---- info = get_integer (symbol); ! /* See how many use names there are. If none, go through the start ! of the loop at least once. */ ! nuse = number_use_names (name); ! if (nuse == 0) ! nuse = 1; ! for (j = 1; j <= nuse; j++) { ! /* Get the jth local name for this symbol. */ ! p = find_use_name_n (name, &j); ! /* Skip symtree nodes not in an ONLY clause. */ ! if (p == NULL) ! continue; ! /* Check for ambiguous symbols. */ ! st = gfc_find_symtree (gfc_current_ns->sym_root, p); ! if (st != NULL) { ! if (st->n.sym != info->u.rsym.sym) ! st->ambiguous = 1; ! info->u.rsym.symtree = st; } + else + { + /* Create a symtree node in the current namespace for this symbol. */ + st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) : + gfc_new_symtree (&gfc_current_ns->sym_root, p); ! st->ambiguous = ambiguous; ! sym = info->u.rsym.sym; ! /* Create a symbol node if it doesn't already exist. */ ! if (sym == NULL) ! { ! sym = info->u.rsym.sym = ! gfc_new_symbol (info->u.rsym.true_name ! , gfc_current_ns); ! ! sym->module = gfc_get_string (info->u.rsym.module); ! } ! ! st->n.sym = sym; ! st->n.sym->refs++; ! ! /* Store the symtree pointing to this symbol. */ ! info->u.rsym.symtree = st; ! ! if (info->u.rsym.state == UNUSED) ! info->u.rsym.state = NEEDED; ! info->u.rsym.referenced = 1; ! } } } *************** read_module (void) *** 3120,3125 **** --- 3264,3270 ---- load_generic_interfaces (); load_commons (); + load_equiv(); /* At this point, we read those symbols that are needed but haven't been loaded yet. If one symbol requires another, the other gets *************** static void *** 3191,3196 **** --- 3336,3342 ---- write_common (gfc_symtree *st) { gfc_common_head *p; + const char * name; if (st == NULL) return; *************** write_common (gfc_symtree *st) *** 3199,3205 **** write_common(st->right); mio_lparen(); ! mio_pool_string(&st->name); p = st->n.common; mio_symbol_ref(&p->head); --- 3345,3355 ---- write_common(st->right); mio_lparen(); ! ! /* Write the unmangled name. */ ! name = st->n.common->name; ! ! mio_pool_string(&name); p = st->n.common; mio_symbol_ref(&p->head); *************** write_common (gfc_symtree *st) *** 3208,3213 **** --- 3358,3408 ---- mio_rparen(); } + /* Write the blank common block to the module */ + + static void + write_blank_common (void) + { + const char * name = BLANK_COMMON_NAME; + + if (gfc_current_ns->blank_common.head == NULL) + return; + + mio_lparen(); + + mio_pool_string(&name); + + mio_symbol_ref(&gfc_current_ns->blank_common.head); + mio_integer(&gfc_current_ns->blank_common.saved); + + mio_rparen(); + } + + /* Write equivalences to the module. */ + + static void + write_equiv(void) + { + gfc_equiv *eq, *e; + int num; + + num = 0; + for(eq=gfc_current_ns->equiv; eq; eq=eq->next) + { + mio_lparen(); + + for(e=eq; e; e=e->eq) + { + if (e->module == NULL) + e->module = gfc_get_string("%s.eq.%d", module_name, num); + mio_allocated_string(e->module); + mio_expr(&e->expr); + } + + num++; + mio_rparen(); + } + } /* Write a symbol to the module. */ *************** write_module (void) *** 3394,3404 **** --- 3589,3605 ---- write_char ('\n'); mio_lparen (); + write_blank_common (); write_common (gfc_current_ns->common_root); mio_rparen (); write_char ('\n'); write_char ('\n'); + mio_lparen(); + write_equiv(); + mio_rparen(); + write_char('\n'); write_char('\n'); + /* Write symbol information. First we traverse all symbols in the primary namespace, writing those that need to be written. Sometimes writing one symbol will cause another to need to be *************** write_module (void) *** 3429,3442 **** void gfc_dump_module (const char *name, int dump_flag) { ! char filename[PATH_MAX], *p; time_t now; ! filename[0] = '\0'; if (gfc_option.module_dir != NULL) ! strcpy (filename, gfc_option.module_dir); ! ! strcat (filename, name); strcat (filename, MODULE_EXTENSION); if (!dump_flag) --- 3630,3651 ---- void gfc_dump_module (const char *name, int dump_flag) { ! int n; ! char *filename, *p; time_t now; ! n = strlen (name) + strlen (MODULE_EXTENSION) + 1; if (gfc_option.module_dir != NULL) ! { ! filename = (char *) alloca (n + strlen (gfc_option.module_dir)); ! strcpy (filename, gfc_option.module_dir); ! strcat (filename, name); ! } ! else ! { ! filename = (char *) alloca (n); ! strcpy (filename, name); ! } strcat (filename, MODULE_EXTENSION); if (!dump_flag) *************** gfc_dump_module (const char *name, int d *** 3482,3491 **** void gfc_use_module (void) { ! char filename[GFC_MAX_SYMBOL_LEN + 5]; gfc_state_data *p; int c, line; strcpy (filename, module_name); strcat (filename, MODULE_EXTENSION); --- 3691,3702 ---- void gfc_use_module (void) { ! char *filename; gfc_state_data *p; int c, line; + filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION) + + 1); strcpy (filename, module_name); strcat (filename, MODULE_EXTENSION); diff -Nrcpad gcc-4.0.1/gcc/fortran/options.c gcc-4.0.2/gcc/fortran/options.c *** gcc-4.0.1/gcc/fortran/options.c Mon Jun 20 20:16:55 2005 --- gcc-4.0.2/gcc/fortran/options.c Wed Aug 31 12:39:27 2005 *************** gfc_init_options (unsigned int argc ATTR *** 70,75 **** --- 70,76 ---- gfc_option.flag_no_backend = 0; gfc_option.flag_pack_derived = 0; gfc_option.flag_repack_arrays = 0; + gfc_option.flag_automatic = 1; gfc_option.flag_backslash = 1; gfc_option.q_kind = gfc_default_double_kind; *************** gfc_init_options (unsigned int argc ATTR *** 78,86 **** flag_errno_math = 0; gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL ! | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F77 | GFC_STD_GNU; gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL ! | GFC_STD_F2003; gfc_option.warn_nonstd_intrinsics = 0; --- 79,88 ---- flag_errno_math = 0; gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL ! | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F77 | GFC_STD_GNU ! | GFC_STD_LEGACY; gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL ! | GFC_STD_F2003 | GFC_STD_LEGACY; gfc_option.warn_nonstd_intrinsics = 0; *************** gfc_post_options (const char **pfilename *** 114,119 **** --- 116,124 ---- /* If -pedantic, warn about the use of GNU extensions. */ if (pedantic && (gfc_option.allow_std & GFC_STD_GNU) != 0) gfc_option.warn_std |= GFC_STD_GNU; + /* -std=legacy -pedantic is effectively -std=gnu. */ + if (pedantic && (gfc_option.allow_std & GFC_STD_LEGACY) != 0) + gfc_option.warn_std |= GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_LEGACY; /* If the user didn't explicitly specify -f(no)-second-underscore we use it if we're trying to be compatible with f2c, and not *************** gfc_handle_option (size_t scode, const c *** 230,235 **** --- 235,244 ---- gfc_option.flag_dollar_ok = value; break; + case OPT_fautomatic: + gfc_option.flag_automatic = value; + break; + case OPT_fbackslash: gfc_option.flag_backslash = value; break; *************** gfc_handle_option (size_t scode, const c *** 338,345 **** case OPT_std_gnu: gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_F77 | GFC_STD_F95 | GFC_STD_F2003 ! | GFC_STD_GNU; ! gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL; break; case OPT_Wnonstd_intrinsics: --- 347,362 ---- case OPT_std_gnu: gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_F77 | GFC_STD_F95 | GFC_STD_F2003 ! | GFC_STD_GNU | GFC_STD_LEGACY; ! gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL ! | GFC_STD_LEGACY; ! break; ! ! case OPT_std_legacy: ! gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL ! | GFC_STD_F77 | GFC_STD_F95 | GFC_STD_F2003 ! | GFC_STD_GNU | GFC_STD_LEGACY; ! gfc_option.warn_std = 0; break; case OPT_Wnonstd_intrinsics: diff -Nrcpad gcc-4.0.1/gcc/fortran/primary.c gcc-4.0.2/gcc/fortran/primary.c *** gcc-4.0.1/gcc/fortran/primary.c Mon Jun 20 20:16:56 2005 --- gcc-4.0.2/gcc/fortran/primary.c Fri Sep 9 09:05:53 2005 *************** match_integer_constant (gfc_expr ** resu *** 228,233 **** --- 228,302 ---- } + /* Match a Hollerith constant. */ + + static match + match_hollerith_constant (gfc_expr ** result) + { + locus old_loc; + gfc_expr * e = NULL; + const char * msg; + char * buffer; + int num; + int i; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + if (match_integer_constant (&e, 0) == MATCH_YES + && gfc_match_char ('h') == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_LEGACY, + "Extension: Hollerith constant at %C") + == FAILURE) + goto cleanup; + + msg = gfc_extract_int (e, &num); + if (msg != NULL) + { + gfc_error (msg); + goto cleanup; + } + if (num == 0) + { + gfc_error ("Invalid Hollerith constant: %L must contain at least one " + "character", &old_loc); + goto cleanup; + } + if (e->ts.kind != gfc_default_integer_kind) + { + gfc_error ("Invalid Hollerith constant: Interger kind at %L " + "should be default", &old_loc); + goto cleanup; + } + else + { + buffer = (char *)gfc_getmem (sizeof(char)*num+1); + for (i = 0; i < num; i++) + { + buffer[i] = gfc_next_char_literal (1); + } + gfc_free_expr (e); + e = gfc_constant_result (BT_HOLLERITH, + gfc_default_character_kind, &gfc_current_locus); + e->value.character.string = gfc_getmem (num+1); + memcpy (e->value.character.string, buffer, num); + e->value.character.length = num; + *result = e; + return MATCH_YES; + } + } + + gfc_free_expr (e); + gfc_current_locus = old_loc; + return MATCH_NO; + + cleanup: + gfc_free_expr (e); + return MATCH_ERROR; + } + + /* Match a binary, octal or hexadecimal constant that can be found in a DATA statement. */ *************** match_complex_constant (gfc_expr ** resu *** 1048,1054 **** m = match_complex_part (&real); if (m == MATCH_NO) ! goto cleanup; if (gfc_match_char (',') == MATCH_NO) { --- 1117,1126 ---- m = match_complex_part (&real); if (m == MATCH_NO) ! { ! gfc_free_error (&old_error); ! goto cleanup; ! } if (gfc_match_char (',') == MATCH_NO) { *************** match_complex_constant (gfc_expr ** resu *** 1063,1069 **** sort. These sort of lists are matched prior to coming here. */ if (m == MATCH_ERROR) ! goto cleanup; gfc_pop_error (&old_error); m = match_complex_part (&imag); --- 1135,1144 ---- sort. These sort of lists are matched prior to coming here. */ if (m == MATCH_ERROR) ! { ! gfc_free_error (&old_error); ! goto cleanup; ! } gfc_pop_error (&old_error); m = match_complex_part (&imag); *************** gfc_match_literal_constant (gfc_expr ** *** 1159,1164 **** --- 1234,1243 ---- if (m != MATCH_NO) return m; + m = match_hollerith_constant (result); + if (m != MATCH_NO) + return m; + m = match_integer_constant (result, signflag); if (m != MATCH_NO) return m; *************** match_varspec (gfc_expr * primary, int e *** 1438,1465 **** char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_ref *substring, *tail; gfc_component *component; ! gfc_symbol *sym; match m; tail = NULL; ! if (primary->symtree->n.sym->attr.dimension ! || (equiv_flag ! && gfc_peek_char () == '(')) { ! tail = extend_ref (primary, tail); tail->type = REF_ARRAY; ! m = gfc_match_array_ref (&tail->u.ar, primary->symtree->n.sym->as, ! equiv_flag); if (m != MATCH_YES) return m; } - sym = primary->symtree->n.sym; primary->ts = sym->ts; if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES) goto check_substring; --- 1517,1558 ---- char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_ref *substring, *tail; gfc_component *component; ! gfc_symbol *sym = primary->symtree->n.sym; match m; tail = NULL; ! if ((equiv_flag && gfc_peek_char () == '(') ! || sym->attr.dimension) { ! /* In EQUIVALENCE, we don't know yet whether we are seeing ! an array, character variable or array of character ! variables. We'll leave the decision till resolve ! time. */ tail = extend_ref (primary, tail); tail->type = REF_ARRAY; ! m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as, ! equiv_flag); if (m != MATCH_YES) return m; + + if (equiv_flag && gfc_peek_char () == '(') + { + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; + + m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag); + if (m != MATCH_YES) + return m; + } } primary->ts = sym->ts; + if (equiv_flag) + return MATCH_YES; + if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES) goto check_substring; *************** gfc_match_rvalue (gfc_expr ** result) *** 1773,1783 **** gfc_set_sym_referenced (sym); ! if (sym->attr.function && sym->result == sym ! && (gfc_current_ns->proc_name == sym || (gfc_current_ns->parent != NULL ! && gfc_current_ns->parent->proc_name == sym))) ! goto variable; if (sym->attr.function || sym->attr.external || sym->attr.intrinsic) goto function0; --- 1866,1889 ---- gfc_set_sym_referenced (sym); ! if (sym->attr.function && sym->result == sym) ! { ! if (gfc_current_ns->proc_name == sym || (gfc_current_ns->parent != NULL ! && gfc_current_ns->parent->proc_name == sym)) ! goto variable; ! ! if (sym->attr.entry ! && (sym->ns == gfc_current_ns ! || sym->ns == gfc_current_ns->parent)) ! { ! gfc_entry_list *el = NULL; ! ! for (el = sym->ns->entries; el; el = el->next) ! if (sym == el->sym) ! goto variable; ! } ! } if (sym->attr.function || sym->attr.external || sym->attr.intrinsic) goto function0; *************** gfc_match_rvalue (gfc_expr ** result) *** 1802,1809 **** break; case FL_PARAMETER: ! if (sym->value ! && sym->value->expr_type != EXPR_ARRAY) e = gfc_copy_expr (sym->value); else { --- 1908,1918 ---- break; case FL_PARAMETER: ! /* A statement of the form "REAL, parameter :: a(0:10) = 1" will ! end up here. Unfortunately, sym->value->expr_type is set to ! EXPR_CONSTANT, and so the if () branch would be followed without ! the !sym->as check. */ ! if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as) e = gfc_copy_expr (sym->value); else { *************** gfc_match_rvalue (gfc_expr ** result) *** 2064,2073 **** starts as a symbol, can be a structure component or an array reference. It can be a function if the function doesn't have a separate RESULT variable. If the symbol has not been previously ! seen, we assume it is a variable. */ ! match ! gfc_match_variable (gfc_expr ** result, int equiv_flag) { gfc_symbol *sym; gfc_symtree *st; --- 2173,2187 ---- starts as a symbol, can be a structure component or an array reference. It can be a function if the function doesn't have a separate RESULT variable. If the symbol has not been previously ! seen, we assume it is a variable. ! This function is called by two interface functions: ! gfc_match_variable, which has host_flag = 1, and ! gfc_match_equiv_variable, with host_flag = 0, to restrict the ! match of the symbol to the local scope. */ ! ! static match ! match_variable (gfc_expr ** result, int equiv_flag, int host_flag) { gfc_symbol *sym; gfc_symtree *st; *************** gfc_match_variable (gfc_expr ** result, *** 2075,2081 **** locus where; match m; ! m = gfc_match_sym_tree (&st, 1); if (m != MATCH_YES) return m; where = gfc_current_locus; --- 2189,2195 ---- locus where; match m; ! m = gfc_match_sym_tree (&st, host_flag); if (m != MATCH_YES) return m; where = gfc_current_locus; *************** gfc_match_variable (gfc_expr ** result, *** 2149,2151 **** --- 2263,2278 ---- *result = expr; return MATCH_YES; } + + match + gfc_match_variable (gfc_expr ** result, int equiv_flag) + { + return match_variable (result, equiv_flag, 1); + } + + match + gfc_match_equiv_variable (gfc_expr ** result) + { + return match_variable (result, 1, 0); + } + diff -Nrcpad gcc-4.0.1/gcc/fortran/resolve.c gcc-4.0.2/gcc/fortran/resolve.c *** gcc-4.0.1/gcc/fortran/resolve.c Wed Jun 1 23:02:05 2005 --- gcc-4.0.2/gcc/fortran/resolve.c Wed Aug 31 12:39:27 2005 *************** resolve_operator (gfc_expr * e) *** 1514,1522 **** break; } ! sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s", ! gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts), ! gfc_typename (&op2->ts)); goto bad_op; --- 1514,1527 ---- break; } ! if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) ! sprintf (msg, "Logicals at %%L must be compared with %s instead of %s", ! e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.", ! gfc_op2string (e->value.op.operator)); ! else ! sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s", ! gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts), ! gfc_typename (&op2->ts)); goto bad_op; *************** gfc_resolve_index (gfc_expr * index, int *** 1823,1828 **** --- 1828,1867 ---- return SUCCESS; } + /* Resolve a dim argument to an intrinsic function. */ + + try + gfc_resolve_dim_arg (gfc_expr *dim) + { + if (dim == NULL) + return SUCCESS; + + if (gfc_resolve_expr (dim) == FAILURE) + return FAILURE; + + if (dim->rank != 0) + { + gfc_error ("Argument dim at %L must be scalar", &dim->where); + return FAILURE; + + } + if (dim->ts.type != BT_INTEGER) + { + gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where); + return FAILURE; + } + if (dim->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts; + + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + + gfc_convert_type_warn (dim, &ts, 2, 0); + } + + return SUCCESS; + } /* Given an expression that contains array references, update those array references to point to the right array specifications. While this is *************** resolve_symbol (gfc_symbol * sym) *** 4031,4039 **** --- 4070,4103 ---- int i; const char *whynot; gfc_namelist *nl; + gfc_symtree * symtree; + gfc_symtree * this_symtree; + gfc_namespace * ns; if (sym->attr.flavor == FL_UNKNOWN) { + + /* If we find that a flavorless symbol is an interface in one of the + parent namespaces, find its symtree in this namespace, free the + symbol and set the symtree to point to the interface symbol. */ + for (ns = gfc_current_ns->parent; ns; ns = ns->parent) + { + symtree = gfc_find_symtree (ns->sym_root, sym->name); + if (symtree && symtree->n.sym->generic) + { + this_symtree = gfc_find_symtree (gfc_current_ns->sym_root, + sym->name); + sym->refs--; + if (!sym->refs) + gfc_free_symbol (sym); + symtree->n.sym->refs++; + this_symtree->n.sym = symtree->n.sym; + return; + } + } + + /* Otherwise give it a flavor according to such attributes as + it has. */ if (sym->attr.external == 0 && sym->attr.intrinsic == 0) sym->attr.flavor = FL_VARIABLE; else *************** resolve_equivalence_derived (gfc_symbol *** 4727,4733 **** sequence derived type containing a pointer at any level of component selection, an automatic object, a function name, an entry name, a result name, a named constant, a structure component, or a subobject of any of ! the preceding objects. */ static void resolve_equivalence (gfc_equiv *eq) --- 4791,4797 ---- sequence derived type containing a pointer at any level of component selection, an automatic object, a function name, an entry name, a result name, a named constant, a structure component, or a subobject of any of ! the preceding objects. A substring shall not have length zero. */ static void resolve_equivalence (gfc_equiv *eq) *************** resolve_equivalence (gfc_equiv *eq) *** 4740,4745 **** --- 4804,4872 ---- for (; eq; eq = eq->eq) { e = eq->expr; + + e->ts = e->symtree->n.sym->ts; + /* match_varspec might not know yet if it is seeing + array reference or substring reference, as it doesn't + know the types. */ + if (e->ref && e->ref->type == REF_ARRAY) + { + gfc_ref *ref = e->ref; + sym = e->symtree->n.sym; + + if (sym->attr.dimension) + { + ref->u.ar.as = sym->as; + ref = ref->next; + } + + /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */ + if (e->ts.type == BT_CHARACTER + && ref + && ref->type == REF_ARRAY + && ref->u.ar.dimen == 1 + && ref->u.ar.dimen_type[0] == DIMEN_RANGE + && ref->u.ar.stride[0] == NULL) + { + gfc_expr *start = ref->u.ar.start[0]; + gfc_expr *end = ref->u.ar.end[0]; + void *mem = NULL; + + /* Optimize away the (:) reference. */ + if (start == NULL && end == NULL) + { + if (e->ref == ref) + e->ref = ref->next; + else + e->ref->next = ref->next; + mem = ref; + } + else + { + ref->type = REF_SUBSTRING; + if (start == NULL) + start = gfc_int_expr (1); + ref->u.ss.start = start; + if (end == NULL && e->ts.cl) + end = gfc_copy_expr (e->ts.cl->length); + ref->u.ss.end = end; + ref->u.ss.length = e->ts.cl; + e->ts.cl = NULL; + } + ref = ref->next; + gfc_free (mem); + } + + /* Any further ref is an error. */ + if (ref) + { + gcc_assert (ref->type == REF_ARRAY); + gfc_error ("Syntax error in EQUIVALENCE statement at %L", + &ref->u.ar.where); + continue; + } + } + if (gfc_resolve_expr (e) == FAILURE) continue; *************** resolve_equivalence (gfc_equiv *eq) *** 4802,4820 **** continue; } - /* Shall not be a structure component. */ r = e->ref; while (r) { ! if (r->type == REF_COMPONENT) ! { ! gfc_error ("Structure component '%s' at %L cannot be an " ! "EQUIVALENCE object", ! r->u.c.component->name, &e->where); ! break; ! } ! r = r->next; ! } } } --- 4929,4958 ---- continue; } r = e->ref; while (r) { ! /* Shall not be a structure component. */ ! if (r->type == REF_COMPONENT) ! { ! gfc_error ("Structure component '%s' at %L cannot be an " ! "EQUIVALENCE object", ! r->u.c.component->name, &e->where); ! break; ! } ! ! /* A substring shall not have length zero. */ ! if (r->type == REF_SUBSTRING) ! { ! if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT) ! { ! gfc_error ("Substring at %L has length zero", ! &r->u.ss.start->where); ! break; ! } ! } ! r = r->next; ! } } } *************** gfc_resolve (gfc_namespace * ns) *** 4914,4920 **** gfc_traverse_ns (ns, resolve_values); ! if (ns->save_all) gfc_save_all (ns); iter_stack = NULL; --- 5052,5058 ---- gfc_traverse_ns (ns, resolve_values); ! if (!gfc_option.flag_automatic || ns->save_all) gfc_save_all (ns); iter_stack = NULL; diff -Nrcpad gcc-4.0.1/gcc/fortran/scanner.c gcc-4.0.2/gcc/fortran/scanner.c *** gcc-4.0.1/gcc/fortran/scanner.c Sat Apr 23 14:08:55 2005 --- gcc-4.0.2/gcc/fortran/scanner.c Fri Aug 19 15:50:43 2005 *************** gfc_release_include_path (void) *** 164,170 **** FILE * gfc_open_included_file (const char *name) { ! char fullname[PATH_MAX]; gfc_directorylist *p; FILE *f; --- 164,170 ---- FILE * gfc_open_included_file (const char *name) { ! char *fullname; gfc_directorylist *p; FILE *f; *************** gfc_open_included_file (const char *name *** 174,182 **** for (p = include_dirs; p; p = p->next) { ! if (strlen (p->path) + strlen (name) + 1 > PATH_MAX) ! continue; ! strcpy (fullname, p->path); strcat (fullname, name); --- 174,180 ---- for (p = include_dirs; p; p = p->next) { ! fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1); strcpy (fullname, p->path); strcat (fullname, name); *************** gfc_gobble_whitespace (void) *** 683,693 **** load_line returns wether the line was truncated. */ static int ! load_line (FILE * input, char **pbuf) { ! int c, maxlen, i, preprocessor_flag; int trunc_flag = 0; - static int buflen = 0; char *buffer; /* Determine the maximum allowed line length. */ --- 681,690 ---- load_line returns wether the line was truncated. */ static int ! load_line (FILE * input, char **pbuf, int *pbuflen) { ! int c, maxlen, i, preprocessor_flag, buflen = *pbuflen; int trunc_flag = 0; char *buffer; /* Determine the maximum allowed line length. */ *************** load_line (FILE * input, char **pbuf) *** 753,767 **** *buffer++ = c; i++; ! if (i >= buflen && (maxlen == 0 || preprocessor_flag)) { ! /* Reallocate line buffer to double size to hold the ! overlong line. */ ! buflen = buflen * 2; ! *pbuf = xrealloc (*pbuf, buflen); ! buffer = (*pbuf)+i; } ! else if (i >= buflen) { /* Truncate the rest of the line. */ for (;;) --- 750,767 ---- *buffer++ = c; i++; ! if (maxlen == 0 || preprocessor_flag) { ! if (i >= buflen) ! { ! /* Reallocate line buffer to double size to hold the ! overlong line. */ ! buflen = buflen * 2; ! *pbuf = xrealloc (*pbuf, buflen + 1); ! buffer = (*pbuf)+i; ! } } ! else if (i >= maxlen) { /* Truncate the rest of the line. */ for (;;) *************** load_line (FILE * input, char **pbuf) *** 782,791 **** && gfc_option.fixed_line_length > 0 && !preprocessor_flag && c != EOF) ! while (i++ < buflen) *buffer++ = ' '; *buffer = '\0'; return trunc_flag; } --- 782,792 ---- && gfc_option.fixed_line_length > 0 && !preprocessor_flag && c != EOF) ! while (i++ < gfc_option.fixed_line_length) *buffer++ = ' '; *buffer = '\0'; + *pbuflen = buflen; return trunc_flag; } *************** preprocessor_line (char *c) *** 839,853 **** line = atoi (c); ! /* Set new line number. */ ! current_file->line = line; ! ! c = strchr (c, ' '); if (c == NULL) ! /* No file name given. */ ! return; ! ! /* Skip spaces. */ while (*c == ' ' || *c == '\t') --- 840,852 ---- line = atoi (c); ! c = strchr (c, ' '); if (c == NULL) ! { ! /* No file name given. Set new line number. */ ! current_file->line = line; ! return; ! } /* Skip spaces. */ while (*c == ' ' || *c == '\t') *************** preprocessor_line (char *c) *** 880,887 **** /* Get flags. */ ! ! flag[1] = flag[2] = flag[3] = flag[4] = flag[5] = false; for (;;) { --- 879,886 ---- /* Get flags. */ ! ! flag[1] = flag[2] = flag[3] = flag[4] = false; for (;;) { *************** preprocessor_line (char *c) *** 895,918 **** if (1 <= i && i <= 4) flag[i] = true; } ! /* Interpret flags. */ ! ! if (flag[1] || flag[3]) /* Starting new file. */ { f = get_file (filename, LC_RENAME); f->up = current_file; current_file = f; } ! if (flag[2]) /* Ending current file. */ { current_file = current_file->up; } ! /* The name of the file can be a temporary file produced by cpp. Replace the name if it is different. */ ! if (strcmp (current_file->filename, filename) != 0) { gfc_free (current_file->filename); --- 894,925 ---- if (1 <= i && i <= 4) flag[i] = true; } ! /* Interpret flags. */ ! ! if (flag[1]) /* Starting new file. */ { f = get_file (filename, LC_RENAME); f->up = current_file; current_file = f; } ! if (flag[2]) /* Ending current file. */ { + if (!current_file->up + || strcmp (current_file->up->filename, filename) != 0) + { + gfc_warning_now ("%s:%d: file %s left but not entered", + current_file->filename, current_file->line, + filename); + return; + } current_file = current_file->up; } ! /* The name of the file can be a temporary file produced by cpp. Replace the name if it is different. */ ! if (strcmp (current_file->filename, filename) != 0) { gfc_free (current_file->filename); *************** preprocessor_line (char *c) *** 920,929 **** strcpy (current_file->filename, filename); } return; bad_cpp_line: ! gfc_warning_now ("%s:%d: Illegal preprocessor directive", current_file->filename, current_file->line); current_file->line++; } --- 927,938 ---- strcpy (current_file->filename, filename); } + /* Set new line number. */ + current_file->line = line; return; bad_cpp_line: ! gfc_warning_now ("%s:%d: Illegal preprocessor directive", current_file->filename, current_file->line); current_file->line++; } *************** load_file (char *filename, bool initial) *** 993,999 **** gfc_linebuf *b; gfc_file *f; FILE *input; ! int len; for (f = current_file; f; f = f->up) if (strcmp (filename, f->filename) == 0) --- 1002,1008 ---- gfc_linebuf *b; gfc_file *f; FILE *input; ! int len, line_len; for (f = current_file; f; f = f->up) if (strcmp (filename, f->filename) == 0) *************** load_file (char *filename, bool initial) *** 1028,1037 **** current_file = f; current_file->line = 1; line = NULL; for (;;) { ! int trunc = load_line (input, &line); len = strlen (line); if (feof (input) && len == 0) --- 1037,1047 ---- current_file = f; current_file->line = 1; line = NULL; + line_len = 0; for (;;) { ! int trunc = load_line (input, &line, &line_len); len = strlen (line); if (feof (input) && len == 0) *************** form_from_filename (const char *filename *** 1121,1135 **** const char *fileext; int i; ! /* Find end of file name. */ i = 0; ! while ((i < PATH_MAX) && (filename[i] != '\0')) i++; - /* Improperly terminated or too-long filename. */ - if (i == PATH_MAX) - return FORM_UNKNOWN; - /* Find last period. */ while (i >= 0 && (filename[i] != '.')) i--; --- 1131,1142 ---- const char *fileext; int i; ! /* Find end of file name. Note, filename is either a NULL pointer or ! a NUL terminated string. */ i = 0; ! while (filename[i] != '\0') i++; /* Find last period. */ while (i >= 0 && (filename[i] != '.')) i--; diff -Nrcpad gcc-4.0.1/gcc/fortran/simplify.c gcc-4.0.2/gcc/fortran/simplify.c *** gcc-4.0.1/gcc/fortran/simplify.c Thu Apr 7 20:50:08 2005 --- gcc-4.0.2/gcc/fortran/simplify.c Tue Jul 12 01:50:48 2005 *************** gfc_simplify_modulo (gfc_expr * a, gfc_e *** 2279,2290 **** mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE); mpfr_floor (iquot, quot); mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE); mpfr_clear (quot); mpfr_clear (iquot); mpfr_clear (term); - - mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE); break; default: --- 2279,2289 ---- mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE); mpfr_floor (iquot, quot); mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE); + mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE); mpfr_clear (quot); mpfr_clear (iquot); mpfr_clear (term); break; default: *************** gfc_convert_constant (gfc_expr * e, bt t *** 3721,3726 **** --- 3720,3728 ---- case BT_COMPLEX: f = gfc_int2complex; break; + case BT_LOGICAL: + f = gfc_int2log; + break; default: goto oops; } *************** gfc_convert_constant (gfc_expr * e, bt t *** 3762,3770 **** break; case BT_LOGICAL: ! if (type != BT_LOGICAL) ! goto oops; ! f = gfc_log2log; break; default: --- 3764,3808 ---- break; case BT_LOGICAL: ! switch (type) ! { ! case BT_INTEGER: ! f = gfc_log2int; ! break; ! case BT_LOGICAL: ! f = gfc_log2log; ! break; ! default: ! goto oops; ! } ! break; ! ! case BT_HOLLERITH: ! switch (type) ! { ! case BT_INTEGER: ! f = gfc_hollerith2int; ! break; ! ! case BT_REAL: ! f = gfc_hollerith2real; ! break; ! ! case BT_COMPLEX: ! f = gfc_hollerith2complex; ! break; ! ! case BT_CHARACTER: ! f = gfc_hollerith2character; ! break; ! ! case BT_LOGICAL: ! f = gfc_hollerith2logical; ! break; ! ! default: ! goto oops; ! } break; default: diff -Nrcpad gcc-4.0.1/gcc/fortran/symbol.c gcc-4.0.2/gcc/fortran/symbol.c *** gcc-4.0.1/gcc/fortran/symbol.c Mon Mar 14 20:15:15 2005 --- gcc-4.0.2/gcc/fortran/symbol.c Wed Sep 7 21:19:13 2005 *************** check_conflict (symbol_attribute * attr, *** 420,425 **** --- 420,426 ---- conf2 (target); conf2 (dummy); conf2 (in_common); + conf2 (save); break; default: *************** gfc_traverse_ns (gfc_namespace * ns, voi *** 2317,2322 **** --- 2318,2342 ---- } + /* Return TRUE if the symbol is an automatic variable. */ + static bool + gfc_is_var_automatic (gfc_symbol * sym) + { + /* Pointer and allocatable variables are never automatic. */ + if (sym->attr.pointer || sym->attr.allocatable) + return false; + /* Check for arrays with non-constant size. */ + if (sym->attr.dimension && sym->as + && !gfc_is_compile_time_shape (sym->as)) + return true; + /* Check for non-constant length character vairables. */ + if (sym->ts.type == BT_CHARACTER + && sym->ts.cl + && gfc_is_constant_expr (sym->ts.cl->length)) + return true; + return false; + } + /* Given a symbol, mark it as SAVEd if it is allowed. */ static void *************** save_symbol (gfc_symbol * sym) *** 2330,2336 **** || sym->attr.dummy || sym->attr.flavor != FL_VARIABLE) return; ! gfc_add_save (&sym->attr, sym->name, &sym->declared_at); } --- 2350,2358 ---- || sym->attr.dummy || sym->attr.flavor != FL_VARIABLE) return; ! /* Automatic objects are not saved. */ ! if (gfc_is_var_automatic (sym)) ! return; gfc_add_save (&sym->attr, sym->name, &sym->declared_at); } diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-array.c gcc-4.0.2/gcc/fortran/trans-array.c *** gcc-4.0.1/gcc/fortran/trans-array.c Sun Jun 5 19:01:52 2005 --- gcc-4.0.2/gcc/fortran/trans-array.c Tue Sep 13 19:02:44 2005 *************** gfc_trans_array_constructor_value (stmtb *** 832,838 **** gfc_add_expr_to_block (&body, tmp); *poffset = fold (build2 (PLUS_EXPR, gfc_array_index_type, ! *poffset, bound)); } if (!INTEGER_CST_P (*poffset)) { --- 832,838 ---- gfc_add_expr_to_block (&body, tmp); *poffset = fold (build2 (PLUS_EXPR, gfc_array_index_type, ! *poffset, build_int_cst (NULL_TREE, n))); } if (!INTEGER_CST_P (*poffset)) { *************** gfc_array_allocate (gfc_se * se, gfc_ref *** 2778,2784 **** /*GCC ARRAYS*/ tree ! gfc_array_deallocate (tree descriptor) { tree var; tree tmp; --- 2778,2784 ---- /*GCC ARRAYS*/ tree ! gfc_array_deallocate (tree descriptor, tree pstat) { tree var; tree tmp; *************** gfc_array_deallocate (tree descriptor) *** 2793,2799 **** /* Parameter is the address of the data component. */ tmp = gfc_chainon_list (NULL_TREE, var); ! tmp = gfc_chainon_list (tmp, integer_zero_node); tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp); gfc_add_expr_to_block (&block, tmp); --- 2793,2799 ---- /* Parameter is the address of the data component. */ tmp = gfc_chainon_list (NULL_TREE, var); ! tmp = gfc_chainon_list (tmp, pstat); tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp); gfc_add_expr_to_block (&block, tmp); *************** gfc_trans_dummy_array_bias (gfc_symbol * *** 3290,3296 **** if (!INTEGER_CST_P (lbound)) { gfc_init_se (&se, NULL); ! gfc_conv_expr_type (&se, sym->as->upper[n], gfc_array_index_type); gfc_add_block_to_block (&block, &se.pre); gfc_add_modify_expr (&block, lbound, se.expr); --- 3290,3296 ---- if (!INTEGER_CST_P (lbound)) { gfc_init_se (&se, NULL); ! gfc_conv_expr_type (&se, sym->as->lower[n], gfc_array_index_type); gfc_add_block_to_block (&block, &se.pre); gfc_add_modify_expr (&block, lbound, se.expr); *************** gfc_trans_deferred_array (gfc_symbol * s *** 4026,4032 **** gfc_start_block (&block); /* Deallocate if still allocated at the end of the procedure. */ ! deallocate = gfc_array_deallocate (descriptor); tmp = gfc_conv_descriptor_data (descriptor); tmp = build2 (NE_EXPR, boolean_type_node, tmp, --- 4026,4032 ---- gfc_start_block (&block); /* Deallocate if still allocated at the end of the procedure. */ ! deallocate = gfc_array_deallocate (descriptor, null_pointer_node); tmp = gfc_conv_descriptor_data (descriptor); tmp = build2 (NE_EXPR, boolean_type_node, tmp, diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-array.h gcc-4.0.2/gcc/fortran/trans-array.h *** gcc-4.0.1/gcc/fortran/trans-array.h Sat Mar 12 21:50:49 2005 --- gcc-4.0.2/gcc/fortran/trans-array.h Fri Jul 8 21:19:28 2005 *************** Software Foundation, 59 Temple Place - S *** 20,26 **** 02111-1307, USA. */ /* Generate code to free an array. */ ! tree gfc_array_deallocate (tree); /* Generate code to initialize an allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ --- 20,26 ---- 02111-1307, USA. */ /* Generate code to free an array. */ ! tree gfc_array_deallocate (tree, tree); /* Generate code to initialize an allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-common.c gcc-4.0.2/gcc/fortran/trans-common.c *** gcc-4.0.1/gcc/fortran/trans-common.c Sun Apr 24 13:59:56 2005 --- gcc-4.0.2/gcc/fortran/trans-common.c Fri Sep 9 09:05:53 2005 *************** typedef struct segment_info *** 119,126 **** static segment_info * current_segment; static gfc_namespace *gfc_common_ns = NULL; - #define BLANK_COMMON_NAME "__BLNK__" - /* Make a segment_info based on a symbol. */ static segment_info * --- 119,124 ---- *************** add_condition (segment_info *f, gfc_equi *** 660,705 **** /* Given a segment element, search through the equivalence lists for unused ! conditions that involve the symbol. Add these rules to the segment. Only ! checks for rules involving the first symbol in the equivalence set. */ ! static bool find_equivalence (segment_info *n) { ! gfc_equiv *e1, *e2, *eq, *other; bool found; ! found = FALSE; for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) { ! other = NULL; ! for (e2 = e1->eq; e2; e2 = e2->eq) ! { ! if (e2->used) ! continue; ! if (e1->expr->symtree->n.sym == n->sym) ! { ! eq = e1; ! other = e2; ! } ! else if (e2->expr->symtree->n.sym == n->sym) { eq = e2; ! other = e1; } ! else ! eq = NULL; ! ! if (eq) { ! add_condition (n, eq, other); ! eq->used = 1; found = TRUE; - /* If this symbol is the first in the chain we may find other - matches. Otherwise we can skip to the next equivalence. */ - if (eq == e2) - break; } } } --- 658,702 ---- /* Given a segment element, search through the equivalence lists for unused ! conditions that involve the symbol. Add these rules to the segment. */ ! static bool find_equivalence (segment_info *n) { ! gfc_equiv *e1, *e2, *eq; bool found; ! found = FALSE; + for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) { ! eq = NULL; ! /* Search the equivalence list, including the root (first) element ! for the symbol that owns the segment. */ ! for (e2 = e1; e2; e2 = e2->eq) ! { ! if (!e2->used && e2->expr->symtree->n.sym == n->sym) { eq = e2; ! break; } ! } ! ! /* Go to the next root element. */ ! if (eq == NULL) ! continue; ! ! eq->used = 1; ! ! /* Now traverse the equivalence list matching the offsets. */ ! for (e2 = e1; e2; e2 = e2->eq) ! { ! if (!e2->used && e2 != eq) { ! add_condition (n, eq, e2); ! e2->used = 1; found = TRUE; } } } *************** translate_common (gfc_common_head *commo *** 808,819 **** /* Add symbols to the segment. */ for (sym = var_list; sym; sym = sym->common_next) { ! if (sym->equiv_built) ! { ! /* Symbol has already been added via an equivalence. */ ! current_segment = common_segment; ! s = find_segment_info (sym); /* Ensure the current location is properly aligned. */ align = TYPE_ALIGN_UNIT (s->field); current_offset = (current_offset + align - 1) &~ (align - 1); --- 805,818 ---- /* Add symbols to the segment. */ for (sym = var_list; sym; sym = sym->common_next) { ! current_segment = common_segment; ! s = find_segment_info (sym); + /* Symbol has already been added via an equivalence. Multiple + use associations of the same common block result in equiv_built + being set but no information about the symbol in the segment. */ + if (s && sym->equiv_built) + { /* Ensure the current location is properly aligned. */ align = TYPE_ALIGN_UNIT (s->field); current_offset = (current_offset + align - 1) &~ (align - 1); *************** finish_equivalences (gfc_namespace *ns) *** 888,893 **** --- 887,893 ---- { gfc_equiv *z, *y; gfc_symbol *sym; + gfc_common_head * c; HOST_WIDE_INT offset; unsigned HOST_WIDE_INT align; bool dummy; *************** finish_equivalences (gfc_namespace *ns) *** 911,918 **** apply_segment_offset (current_segment, offset); ! /* Create the decl. */ ! create_common (NULL, current_segment, true); break; } } --- 911,933 ---- apply_segment_offset (current_segment, offset); ! /* Create the decl. If this is a module equivalence, it has a unique ! name, pointed to by z->module. This is written to a gfc_common_header ! to push create_common into using build_common_decl, so that the ! equivalence appears as an external symbol. Otherwise, a local ! declaration is built using build_equiv_decl.*/ ! if (z->module) ! { ! c = gfc_get_common_head (); ! /* We've lost the real location, so use the location of the ! enclosing procedure. */ ! c->where = ns->proc_name->declared_at; ! strcpy (c->name, z->module); ! } ! else ! c = NULL; ! ! create_common (c, current_segment, true); break; } } diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-const.c gcc-4.0.2/gcc/fortran/trans-const.c *** gcc-4.0.1/gcc/fortran/trans-const.c Wed May 18 10:00:56 2005 --- gcc-4.0.2/gcc/fortran/trans-const.c Tue Jul 12 01:50:48 2005 *************** gfc_conv_constant_to_tree (gfc_expr * ex *** 299,327 **** { gcc_assert (expr->expr_type == EXPR_CONSTANT); switch (expr->ts.type) { case BT_INTEGER: ! return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); case BT_REAL: ! return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind); case BT_LOGICAL: ! return build_int_cst (gfc_get_logical_type (expr->ts.kind), expr->value.logical); case BT_COMPLEX: ! { ! tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r, expr->ts.kind); ! tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i, expr->ts.kind); ! return build_complex (NULL_TREE, real, imag); ! } case BT_CHARACTER: return gfc_build_string_const (expr->value.character.length, expr->value.character.string); --- 299,356 ---- { gcc_assert (expr->expr_type == EXPR_CONSTANT); + /* If it is converted from Hollerith constant, we build string constant + and VIEW_CONVERT to its type. */ + switch (expr->ts.type) { case BT_INTEGER: ! if (expr->from_H) ! return build1 (VIEW_CONVERT_EXPR, ! gfc_get_int_type (expr->ts.kind), ! gfc_build_string_const (expr->value.character.length, ! expr->value.character.string)); ! else ! return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); case BT_REAL: ! if (expr->from_H) ! return build1 (VIEW_CONVERT_EXPR, ! gfc_get_real_type (expr->ts.kind), ! gfc_build_string_const (expr->value.character.length, ! expr->value.character.string)); ! else ! return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind); case BT_LOGICAL: ! if (expr->from_H) ! return build1 (VIEW_CONVERT_EXPR, ! gfc_get_logical_type (expr->ts.kind), ! gfc_build_string_const (expr->value.character.length, ! expr->value.character.string)); ! else ! return build_int_cst (gfc_get_logical_type (expr->ts.kind), expr->value.logical); case BT_COMPLEX: ! if (expr->from_H) ! return build1 (VIEW_CONVERT_EXPR, ! gfc_get_complex_type (expr->ts.kind), ! gfc_build_string_const (expr->value.character.length, ! expr->value.character.string)); ! else ! { ! tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r, expr->ts.kind); ! tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i, expr->ts.kind); ! return build_complex (gfc_typenode_for_spec (&expr->ts), ! real, imag); ! } case BT_CHARACTER: + case BT_HOLLERITH: return gfc_build_string_const (expr->value.character.length, expr->value.character.string); diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-decl.c gcc-4.0.2/gcc/fortran/trans-decl.c *** gcc-4.0.1/gcc/fortran/trans-decl.c Wed Jun 1 23:02:06 2005 --- gcc-4.0.2/gcc/fortran/trans-decl.c Fri Sep 9 09:05:53 2005 *************** tree gfor_fndecl_stop_numeric; *** 84,89 **** --- 84,90 ---- tree gfor_fndecl_stop_string; tree gfor_fndecl_select_string; tree gfor_fndecl_runtime_error; + tree gfor_fndecl_set_std; tree gfor_fndecl_in_pack; tree gfor_fndecl_in_unpack; tree gfor_fndecl_associated; *************** gfc_build_builtin_function_decls (void) *** 1874,1879 **** --- 1875,1881 ---- tree gfc_int4_type_node = gfc_get_int_type (4); tree gfc_int8_type_node = gfc_get_int_type (8); tree gfc_logical4_type_node = gfc_get_logical_type (4); + tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node); gfor_fndecl_internal_malloc = gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")), *************** gfc_build_builtin_function_decls (void) *** 1900,1906 **** gfor_fndecl_deallocate = gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")), ! void_type_node, 1, ppvoid_type_node); gfor_fndecl_stop_numeric = gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")), --- 1902,1909 ---- gfor_fndecl_deallocate = gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")), ! void_type_node, 2, ppvoid_type_node, ! gfc_pint4_type_node); gfor_fndecl_stop_numeric = gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")), *************** gfc_build_builtin_function_decls (void) *** 1931,1936 **** --- 1934,1946 ---- pchar_type_node, pchar_type_node, gfc_int4_type_node); + gfor_fndecl_set_std = + gfc_build_library_function_decl (get_identifier (PREFIX("set_std")), + void_type_node, + 2, + gfc_int4_type_node, + gfc_int4_type_node); + gfor_fndecl_in_pack = gfc_build_library_function_decl ( get_identifier (PREFIX("internal_pack")), pvoid_type_node, 1, pvoid_type_node); *************** gfc_create_module_variable (gfc_symbol * *** 2138,2143 **** --- 2148,2157 ---- if (sym->attr.use_assoc || sym->attr.in_common) return; + /* Equivalenced variables arrive here after creation. */ + if (sym->backend_decl && sym->equiv_built) + return; + if (sym->backend_decl) internal_error ("backend decl for module variable %s already exists", sym->name); *************** gfc_generate_function_code (gfc_namespac *** 2314,2321 **** gfc_start_block (&block); - gfc_generate_contained_functions (ns); - if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER) { /* Copy length backend_decls to all entry point result --- 2328,2333 ---- *************** gfc_generate_function_code (gfc_namespac *** 2332,2337 **** --- 2344,2351 ---- /* Translate COMMON blocks. */ gfc_trans_common (ns); + gfc_generate_contained_functions (ns); + generate_local_vars (ns); current_function_return_label = NULL; *************** gfc_generate_function_code (gfc_namespac *** 2339,2344 **** --- 2353,2376 ---- /* Now generate the code for the body of this function. */ gfc_init_block (&body); + /* If this is the main program and we compile with -pedantic, add a call + to set_std to set up the runtime library Fortran language standard + parameters. */ + if (sym->attr.is_main_program && pedantic) + { + tree arglist, gfc_int4_type_node; + + gfc_int4_type_node = gfc_get_int_type (4); + arglist = gfc_chainon_list (NULL_TREE, + build_int_cst (gfc_int4_type_node, + gfc_option.warn_std)); + arglist = gfc_chainon_list (arglist, + build_int_cst (gfc_int4_type_node, + gfc_option.allow_std)); + tmp = gfc_build_function_call (gfor_fndecl_set_std, arglist); + gfc_add_expr_to_block (&body, tmp); + } + if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node && sym->attr.subroutine) { diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-expr.c gcc-4.0.2/gcc/fortran/trans-expr.c *** gcc-4.0.1/gcc/fortran/trans-expr.c Sun Jun 5 08:59:18 2005 --- gcc-4.0.2/gcc/fortran/trans-expr.c Tue Aug 16 13:27:35 2005 *************** gfc_conv_power_op (gfc_se * se, gfc_expr *** 654,659 **** --- 654,660 ---- gfc_init_se (&lse, se); gfc_conv_expr_val (&lse, expr->value.op.op1); + lse.expr = gfc_evaluate_now (lse.expr, &lse.pre); gfc_add_block_to_block (&se->pre, &lse.pre); gfc_init_se (&rse, se); *************** gfc_conv_function_val (gfc_se * se, gfc_ *** 1074,1082 **** /* Generate code for a procedure call. Note can return se->post != NULL. ! If se->direct_byref is set then se->expr contains the return parameter. */ ! void gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_actual_arglist * arg) { --- 1075,1084 ---- /* Generate code for a procedure call. Note can return se->post != NULL. ! If se->direct_byref is set then se->expr contains the return parameter. ! Return non-zero, if the call has alternate specifiers. */ ! int gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, gfc_actual_arglist * arg) { *************** gfc_conv_function_call (gfc_se * se, gfc *** 1092,1097 **** --- 1094,1100 ---- tree len; tree stringargs; gfc_formal_arglist *formal; + int has_alternate_specifier = 0; arglist = NULL_TREE; stringargs = NULL_TREE; *************** gfc_conv_function_call (gfc_se * se, gfc *** 1124,1130 **** /* Bundle in the string length. */ se->string_length = len; ! return; } } info = &se->ss->data.info; --- 1127,1133 ---- /* Bundle in the string length. */ se->string_length = len; ! return 0; } } info = &se->ss->data.info; *************** gfc_conv_function_call (gfc_se * se, gfc *** 1308,1316 **** /* Generate the actual call. */ gfc_conv_function_val (se, sym); /* If there are alternate return labels, function type should be ! integer. */ ! if (has_alternate_specifier) ! TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node; fntype = TREE_TYPE (TREE_TYPE (se->expr)); se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr, --- 1311,1327 ---- /* Generate the actual call. */ gfc_conv_function_val (se, sym); /* If there are alternate return labels, function type should be ! integer. Can't modify the type in place though, since it can be shared ! with other functions. */ ! if (has_alternate_specifier ! && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node) ! { ! gcc_assert (! sym->attr.dummy); ! TREE_TYPE (sym->backend_decl) ! = build_function_type (integer_type_node, ! TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl))); ! se->expr = gfc_build_addr_expr (NULL, sym->backend_decl); ! } fntype = TREE_TYPE (TREE_TYPE (se->expr)); se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr, *************** gfc_conv_function_call (gfc_se * se, gfc *** 1382,1387 **** --- 1393,1400 ---- } } } + + return has_alternate_specifier; } *************** gfc_conv_substring_expr (gfc_se * se, gf *** 1877,1883 **** } ! /* Entry point for expression translation. */ void gfc_conv_expr (gfc_se * se, gfc_expr * expr) --- 1890,1898 ---- } ! /* Entry point for expression translation. Evaluates a scalar quantity. ! EXPR is the expression to be translated, and SE is the state structure if ! called from within the scalarized. */ void gfc_conv_expr (gfc_se * se, gfc_expr * expr) *************** gfc_conv_expr (gfc_se * se, gfc_expr * e *** 1933,1947 **** } } void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr) { gfc_conv_expr (se, expr); ! /* AFAICS all numeric lvalues have empty post chains. If not we need to figure out a way of rewriting an lvalue so that it has no post chain. */ ! gcc_assert (expr->ts.type != BT_CHARACTER || !se->post.head); } void gfc_conv_expr_val (gfc_se * se, gfc_expr * expr) { --- 1948,1967 ---- } } + /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs + of an assignment. */ void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr) { gfc_conv_expr (se, expr); ! /* All numeric lvalues should have empty post chains. If not we need to figure out a way of rewriting an lvalue so that it has no post chain. */ ! gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head); } + /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for + numeric expressions. Used for scalar values whee inserting cleanup code + is inconvenient. */ void gfc_conv_expr_val (gfc_se * se, gfc_expr * expr) { *************** gfc_conv_expr_val (gfc_se * se, gfc_expr *** 1953,1961 **** --- 1973,1984 ---- { val = gfc_create_var (TREE_TYPE (se->expr), NULL); gfc_add_modify_expr (&se->pre, val, se->expr); + se->expr = val; + gfc_add_block_to_block (&se->pre, &se->post); } } + /* Helper to translate and expression and convert it to a particular type. */ void gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type) { diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-intrinsic.c gcc-4.0.2/gcc/fortran/trans-intrinsic.c *** gcc-4.0.1/gcc/fortran/trans-intrinsic.c Sat May 21 16:58:34 2005 --- gcc-4.0.2/gcc/fortran/trans-intrinsic.c Tue Aug 9 17:44:03 2005 *************** gfc_conv_intrinsic_function (gfc_se * se *** 2996,3001 **** --- 2996,3002 ---- case GFC_ISYM_KILL: case GFC_ISYM_IERRNO: case GFC_ISYM_IRAND: + case GFC_ISYM_ISATTY: case GFC_ISYM_LINK: case GFC_ISYM_MATMUL: case GFC_ISYM_RAND: diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-io.c gcc-4.0.2/gcc/fortran/trans-io.c *** gcc-4.0.1/gcc/fortran/trans-io.c Sun Jun 5 23:33:43 2005 --- gcc-4.0.2/gcc/fortran/trans-io.c Tue Jul 12 01:50:48 2005 *************** set_parameter_ref (stmtblock_t * block, *** 364,369 **** --- 364,431 ---- gfc_add_modify_expr (block, tmp, se.expr); } + /* Given an array expr, find its address and length to get a string. If the + array is full, the string's address is the address of array's first element + and the length is the size of the whole array. If it is an element, the + string's address is the element's address and the length is the rest size of + the array. + */ + + static void + gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) + { + tree tmp; + tree array; + tree type; + tree size; + int rank; + gfc_symbol *sym; + + sym = e->symtree->n.sym; + rank = sym->as->rank - 1; + + if (e->ref->u.ar.type == AR_FULL) + { + se->expr = gfc_get_symbol_decl (sym); + se->expr = gfc_conv_array_data (se->expr); + } + else + { + gfc_conv_expr (se, e); + } + + array = sym->backend_decl; + type = TREE_TYPE (array); + + if (GFC_ARRAY_TYPE_P (type)) + size = GFC_TYPE_ARRAY_SIZE (type); + else + { + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + size = gfc_conv_array_stride (array, rank); + tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, + gfc_conv_array_ubound (array, rank), + gfc_conv_array_lbound (array, rank))); + tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, + gfc_index_one_node)); + size = fold (build2 (MULT_EXPR, gfc_array_index_type, tmp, size)); + } + + gcc_assert (size); + + /* If it is an element, we need the its address and size of the rest. */ + if (e->ref->u.ar.type == AR_ELEMENT) + { + size = fold (build2 (MINUS_EXPR, gfc_array_index_type, size, + TREE_OPERAND (se->expr, 1))); + se->expr = gfc_build_addr_expr (NULL, se->expr); + } + + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp)); + + se->string_length = fold_convert (gfc_charlen_type_node, size); + } /* Generate code to store a string and its length into the ioparm structure. */ *************** set_string (stmtblock_t * block, stmtblo *** 400,406 **** } else { ! gfc_conv_expr (&se, e); gfc_conv_string_parameter (&se); gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); gfc_add_modify_expr (&se.pre, len, se.string_length); --- 462,476 ---- } else { ! /* General character. */ ! if (e->ts.type == BT_CHARACTER && e->rank == 0) ! gfc_conv_expr (&se, e); ! /* Array assigned Hollerith constant or character array. */ ! else if (e->symtree && (e->symtree->n.sym->as->rank > 0)) ! gfc_convert_array_to_string (&se, e); ! else ! gcc_unreachable (); ! gfc_conv_string_parameter (&se); gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); gfc_add_modify_expr (&se.pre, len, se.string_length); *************** set_string (stmtblock_t * block, stmtblo *** 408,414 **** gfc_add_block_to_block (block, &se.pre); gfc_add_block_to_block (postblock, &se.post); - } --- 478,483 ---- diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-stmt.c gcc-4.0.2/gcc/fortran/trans-stmt.c *** gcc-4.0.1/gcc/fortran/trans-stmt.c Mon Jun 13 18:30:14 2005 --- gcc-4.0.2/gcc/fortran/trans-stmt.c Mon Jul 11 07:36:58 2005 *************** Software Foundation, 59 Temple Place - S *** 37,44 **** #include "trans-const.h" #include "arith.h" - int has_alternate_specifier; - typedef struct iter_info { tree var; --- 37,42 ---- *************** tree *** 208,213 **** --- 206,212 ---- gfc_trans_call (gfc_code * code) { gfc_se se; + int has_alternate_specifier; /* A CALL starts a new block because the actual arguments may have to be evaluated first. */ *************** gfc_trans_call (gfc_code * code) *** 215,224 **** gfc_start_block (&se.pre); gcc_assert (code->resolved_sym); - has_alternate_specifier = 0; /* Translate the call. */ ! gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual); /* A subroutine without side-effect, by definition, does nothing! */ TREE_SIDE_EFFECTS (se.expr) = 1; --- 214,223 ---- gfc_start_block (&se.pre); gcc_assert (code->resolved_sym); /* Translate the call. */ ! has_alternate_specifier ! = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual); /* A subroutine without side-effect, by definition, does nothing! */ TREE_SIDE_EFFECTS (se.expr) = 1; *************** gfc_trans_forall_loop (forall_info *fora *** 1334,1340 **** stmtblock_t block; tree exit_label; tree count; ! tree var, start, end, step, mask, maskindex; iter_info *iter; iter = forall_tmp->this_loop; --- 1333,1339 ---- stmtblock_t block; tree exit_label; tree count; ! tree var, start, end, step; iter_info *iter; iter = forall_tmp->this_loop; *************** gfc_trans_forall_loop (forall_info *fora *** 1369,1385 **** /* Advance to the next mask element. Only do this for the innermost loop. */ ! if (n == 0 && mask_flag) ! { ! mask = forall_tmp->mask; ! maskindex = forall_tmp->maskindex; ! if (mask) ! { ! tmp = build2 (PLUS_EXPR, gfc_array_index_type, ! maskindex, gfc_index_one_node); ! gfc_add_modify_expr (&block, maskindex, tmp); ! } ! } /* Decrement the loop counter. */ tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node); gfc_add_modify_expr (&block, count, tmp); --- 1368,1381 ---- /* Advance to the next mask element. Only do this for the innermost loop. */ ! if (n == 0 && mask_flag && forall_tmp->mask) ! { ! tree maskindex = forall_tmp->maskindex; ! tmp = build2 (PLUS_EXPR, gfc_array_index_type, ! maskindex, gfc_index_one_node); ! gfc_add_modify_expr (&block, maskindex, tmp); ! } ! /* Decrement the loop counter. */ tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node); gfc_add_modify_expr (&block, count, tmp); *************** gfc_trans_forall_loop (forall_info *fora *** 1390,1395 **** --- 1386,1397 ---- gfc_init_block (&block); gfc_add_modify_expr (&block, var, start); + /* Initialize maskindex counter. Only do this before the + outermost loop. */ + if (n == nvar - 1 && mask_flag && forall_tmp->mask) + gfc_add_modify_expr (&block, forall_tmp->maskindex, + gfc_index_zero_node); + /* Initialize the loop counter. */ tmp = fold (build2 (MINUS_EXPR, TREE_TYPE (var), step, start)); tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp)); *************** gfc_trans_assign_need_temp (gfc_expr * e *** 1933,1940 **** tree count, count1; tree tmp, tmp1; tree ptemp1; - tree mask, maskindex; - forall_info *forall_tmp; stmtblock_t inner_size_body; /* Create vars. count1 is the current iterator number of the nested --- 1935,1940 ---- *************** gfc_trans_assign_need_temp (gfc_expr * e *** 1967,1983 **** tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size, &inner_size_body, block, &ptemp1); - /* Initialize the maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - /* Generate codes to copy rhs to the temporary . */ tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss, wheremask); --- 1967,1972 ---- *************** gfc_trans_assign_need_temp (gfc_expr * e *** 1990,2006 **** /* Reset count1. */ gfc_add_modify_expr (block, count1, gfc_index_zero_node); - /* Reset maskindexed. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - /* Reset count. */ if (wheremask) gfc_add_modify_expr (block, count, gfc_index_zero_node); --- 1979,1984 ---- *************** gfc_trans_pointer_assign_need_temp (gfc_ *** 2043,2050 **** stmtblock_t body; tree count; tree tmp, tmp1, ptemp1; - tree mask, maskindex; - forall_info *forall_tmp; count = gfc_create_var (gfc_array_index_type, "count"); gfc_add_modify_expr (block, count, gfc_index_zero_node); --- 2021,2026 ---- *************** gfc_trans_pointer_assign_need_temp (gfc_ *** 2078,2094 **** tmp = gfc_finish_block (&body); - /* Initialize the maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - /* Generate body and loops according to the information in nested_forall_info. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); --- 2054,2059 ---- *************** gfc_trans_pointer_assign_need_temp (gfc_ *** 2097,2112 **** /* Reset count. */ gfc_add_modify_expr (block, count, gfc_index_zero_node); - /* Reset maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } gfc_start_block (&body); gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); --- 2062,2067 ---- *************** gfc_trans_pointer_assign_need_temp (gfc_ *** 2167,2183 **** tmp = gfc_finish_block (&body); - /* Initialize the maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - /* Generate body and loops according to the information in nested_forall_info. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); --- 2122,2127 ---- *************** gfc_trans_pointer_assign_need_temp (gfc_ *** 2186,2201 **** /* Reset count. */ gfc_add_modify_expr (block, count, gfc_index_zero_node); - /* Reset maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - if (mask) - gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } parm = gfc_build_array_ref (tmp1, count); lss = gfc_walk_expr (expr1); gfc_init_se (&lse, NULL); --- 2130,2135 ---- *************** gfc_trans_forall_1 (gfc_code * code, for *** 2414,2424 **** For now we assume a mask temporary is needed. */ if (code->expr) { /* Allocate the mask temporary. */ bytesize = fold (build2 (MULT_EXPR, gfc_array_index_type, size, ! TYPE_SIZE_UNIT (boolean_type_node))); ! mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node); maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); /* Record them in the info structure. */ --- 2348,2364 ---- For now we assume a mask temporary is needed. */ if (code->expr) { + /* As the mask array can be very big, prefer compact + boolean types. */ + tree smallest_boolean_type_node + = gfc_get_logical_type (gfc_logical_kinds[0].kind); + /* Allocate the mask temporary. */ bytesize = fold (build2 (MULT_EXPR, gfc_array_index_type, size, ! TYPE_SIZE_UNIT (smallest_boolean_type_node))); ! mask = gfc_do_allocate (bytesize, size, &pmask, &block, ! smallest_boolean_type_node); maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); /* Record them in the info structure. */ *************** gfc_trans_forall_1 (gfc_code * code, for *** 2437,2443 **** gfc_add_block_to_block (&body, &se.pre); /* Store the mask. */ ! se.expr = convert (boolean_type_node, se.expr); if (pmask) tmp = gfc_build_indirect_ref (mask); --- 2377,2383 ---- gfc_add_block_to_block (&body, &se.pre); /* Store the mask. */ ! se.expr = convert (smallest_boolean_type_node, se.expr); if (pmask) tmp = gfc_build_indirect_ref (mask); *************** gfc_trans_forall_1 (gfc_code * code, for *** 2484,2493 **** /* Use the normal assignment copying routines. */ assign = gfc_trans_assignment (c->expr, c->expr2); - /* Reset the mask index. */ - if (mask) - gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node); - /* Generate body and loops. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); gfc_add_expr_to_block (&block, tmp); --- 2424,2429 ---- *************** gfc_trans_forall_1 (gfc_code * code, for *** 2529,2538 **** /* Use the normal assignment copying routines. */ assign = gfc_trans_pointer_assignment (c->expr, c->expr2); - /* Reset the mask index. */ - if (mask) - gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node); - /* Generate body and loops. */ tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); --- 2465,2470 ---- *************** gfc_evaluate_where_mask (gfc_expr * me, *** 2720,2741 **** tmp1 = gfc_finish_block (&body); /* If the WHERE construct is inside FORALL, fill the full temporary. */ if (nested_forall_info != NULL) ! { ! forall_info *forall_tmp; ! tree maskindex; ! ! /* Initialize the maskindexes. */ ! forall_tmp = nested_forall_info; ! while (forall_tmp != NULL) ! { ! maskindex = forall_tmp->maskindex; ! if (forall_tmp->mask) ! gfc_add_modify_expr (block, maskindex, gfc_index_zero_node); ! forall_tmp = forall_tmp->next_nest; ! } ! ! tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1); ! } gfc_add_expr_to_block (block, tmp1); --- 2652,2658 ---- tmp1 = gfc_finish_block (&body); /* If the WHERE construct is inside FORALL, fill the full temporary. */ if (nested_forall_info != NULL) ! tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1); gfc_add_expr_to_block (block, tmp1); *************** gfc_trans_where_2 (gfc_code * code, tree *** 3056,3064 **** nested_forall_info, block); else { - forall_info *forall_tmp; - tree maskindex; - /* Variables to control maskexpr. */ count1 = gfc_create_var (gfc_array_index_type, "count1"); count2 = gfc_create_var (gfc_array_index_type, "count2"); --- 2973,2978 ---- *************** gfc_trans_where_2 (gfc_code * code, tree *** 3068,3084 **** tmp = gfc_trans_where_assign (expr1, expr2, mask, count1, count2); - /* Initialize the maskindexes. */ - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - maskindex = forall_tmp->maskindex; - if (forall_tmp->mask) - gfc_add_modify_expr (block, maskindex, - gfc_index_zero_node); - forall_tmp = forall_tmp->next_nest; - } - tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); gfc_add_expr_to_block (block, tmp); --- 2982,2987 ---- *************** gfc_trans_allocate (gfc_code * code) *** 3291,3309 **** } tree gfc_trans_deallocate (gfc_code * code) { gfc_se se; gfc_alloc *al; gfc_expr *expr; ! tree var; ! tree tmp; ! tree type; stmtblock_t block; gfc_start_block (&block); for (al = code->ext.alloc_list; al != NULL; al = al->next) { expr = al->expr; --- 3194,3249 ---- } + /* Translate a DEALLOCATE statement. + There are two cases within the for loop: + (1) deallocate(a1, a2, a3) is translated into the following sequence + _gfortran_deallocate(a1, 0B) + _gfortran_deallocate(a2, 0B) + _gfortran_deallocate(a3, 0B) + where the STAT= variable is passed a NULL pointer. + (2) deallocate(a1, a2, a3, stat=i) is translated into the following + astat = 0 + _gfortran_deallocate(a1, &stat) + astat = astat + stat + _gfortran_deallocate(a2, &stat) + astat = astat + stat + _gfortran_deallocate(a3, &stat) + astat = astat + stat + In case (1), we simply return at the end of the for loop. In case (2) + we set STAT= astat. */ tree gfc_trans_deallocate (gfc_code * code) { gfc_se se; gfc_alloc *al; gfc_expr *expr; ! tree apstat, astat, parm, pstat, stat, tmp, type, var; stmtblock_t block; gfc_start_block (&block); + /* Set up the optional STAT= */ + if (code->expr) + { + tree gfc_int4_type_node = gfc_get_int_type (4); + + /* Variable used with the library call. */ + stat = gfc_create_var (gfc_int4_type_node, "stat"); + pstat = gfc_build_addr_expr (NULL, stat); + + /* Running total of possible deallocation failures. */ + astat = gfc_create_var (gfc_int4_type_node, "astat"); + apstat = gfc_build_addr_expr (NULL, astat); + + /* Initialize astat to 0. */ + gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); + } + else + { + pstat = apstat = null_pointer_node; + stat = astat = NULL_TREE; + } + for (al = code->ext.alloc_list; al != NULL; al = al->next) { expr = al->expr; *************** gfc_trans_deallocate (gfc_code * code) *** 3317,3326 **** gfc_conv_expr (&se, expr); if (expr->symtree->n.sym->attr.dimension) ! { ! tmp = gfc_array_deallocate (se.expr); ! gfc_add_expr_to_block (&se.pre, tmp); ! } else { type = build_pointer_type (TREE_TYPE (se.expr)); --- 3257,3263 ---- gfc_conv_expr (&se, expr); if (expr->symtree->n.sym->attr.dimension) ! tmp = gfc_array_deallocate (se.expr, pstat); else { type = build_pointer_type (TREE_TYPE (se.expr)); *************** gfc_trans_deallocate (gfc_code * code) *** 3328,3340 **** tmp = gfc_build_addr_expr (type, se.expr); gfc_add_modify_expr (&se.pre, var, tmp); ! tmp = gfc_chainon_list (NULL_TREE, var); ! tmp = gfc_chainon_list (tmp, integer_zero_node); ! tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp); ! gfc_add_expr_to_block (&se.pre, tmp); } tmp = gfc_finish_block (&se.pre); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); --- 3265,3297 ---- tmp = gfc_build_addr_expr (type, se.expr); gfc_add_modify_expr (&se.pre, var, tmp); ! parm = gfc_chainon_list (NULL_TREE, var); ! parm = gfc_chainon_list (parm, pstat); ! tmp = gfc_build_function_call (gfor_fndecl_deallocate, parm); ! } ! ! gfc_add_expr_to_block (&se.pre, tmp); ! ! /* Keep track of the number of failed deallocations by adding stat ! of the last deallocation to the running total. */ ! if (code->expr) ! { ! apstat = build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat); ! gfc_add_modify_expr (&se.pre, astat, apstat); } + tmp = gfc_finish_block (&se.pre); gfc_add_expr_to_block (&block, tmp); + + } + + /* Assign the value to the status variable. */ + if (code->expr) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr); + tmp = convert (TREE_TYPE (se.expr), astat); + gfc_add_modify_expr (&block, se.expr, tmp); } return gfc_finish_block (&block); diff -Nrcpad gcc-4.0.1/gcc/fortran/trans-types.h gcc-4.0.2/gcc/fortran/trans-types.h *** gcc-4.0.1/gcc/fortran/trans-types.h Tue Nov 16 02:02:37 2004 --- gcc-4.0.2/gcc/fortran/trans-types.h Sat Sep 10 21:40:00 2005 *************** enum *** 41,50 **** --- 41,52 ---- }; extern GTY(()) tree gfc_array_index_type; + extern GTY(()) tree gfc_array_range_type; extern GTY(()) tree gfc_character1_type_node; extern GTY(()) tree ppvoid_type_node; extern GTY(()) tree pvoid_type_node; extern GTY(()) tree pchar_type_node; + /* This is the type used to hold the lengths of character variables. It must be the same as the corresponding definition in gfortran.h. */ /* TODO: This is still hardcoded as kind=4 in some bits of the compiler diff -Nrcpad gcc-4.0.1/gcc/fortran/trans.c gcc-4.0.2/gcc/fortran/trans.c *** gcc-4.0.1/gcc/fortran/trans.c Sat Jun 4 22:43:14 2005 --- gcc-4.0.2/gcc/fortran/trans.c Thu Aug 11 13:53:19 2005 *************** gfc_trans_code (gfc_code * code) *** 646,654 **** void gfc_generate_code (gfc_namespace * ns) { - gfc_symbol *main_program = NULL; - symbol_attribute attr; - if (ns->is_block_data) { gfc_generate_block_data (ns); --- 646,651 ---- *************** gfc_generate_code (gfc_namespace * ns) *** 658,663 **** --- 655,663 ---- /* Main program subroutine. */ if (!ns->proc_name) { + gfc_symbol *main_program; + symbol_attribute attr; + /* Lots of things get upset if a subroutine doesn't have a symbol, so we make one now. Hopefully we've set all the required fields. */ gfc_get_symbol ("MAIN__", ns, &main_program); *************** gfc_generate_code (gfc_namespace * ns) *** 666,672 **** --- 666,674 ---- attr.proc = PROC_UNKNOWN; attr.subroutine = 1; attr.access = ACCESS_PUBLIC; + attr.is_main_program = 1; main_program->attr = attr; + /* Set the location to the first line of code. */ if (ns->code) main_program->declared_at = ns->code->loc; diff -Nrcpad gcc-4.0.1/gcc/fortran/trans.h gcc-4.0.2/gcc/fortran/trans.h *** gcc-4.0.1/gcc/fortran/trans.h Tue Mar 15 03:42:48 2005 --- gcc-4.0.2/gcc/fortran/trans.h Thu Aug 11 13:53:19 2005 *************** tree gfc_chainon_list (tree, tree); *** 275,294 **** when a POST chain may be created, and what the retured expression may be used for. Note that character strings have special handling. This should not be a problem as most statements/operations only deal with ! numeric/logical types. */ - /* Entry point for expression translation. */ void gfc_conv_expr (gfc_se * se, gfc_expr * expr); - /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for - numeric expressions. */ void gfc_conv_expr_val (gfc_se * se, gfc_expr * expr); - /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs of - an assignment. */ void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr); - /* Converts an expression so that it can be passed be reference. */ void gfc_conv_expr_reference (gfc_se * se, gfc_expr *); - /* Equivalent to convert(type, gfc_conv_expr_val(se, expr)). */ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); /* Find the decl containing the auxiliary variables for assigned variables. */ void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); /* If the value is not constant, Create a temporary and copy the value. */ --- 275,289 ---- when a POST chain may be created, and what the retured expression may be used for. Note that character strings have special handling. This should not be a problem as most statements/operations only deal with ! numeric/logical types. See the implementations in trans-expr.c ! for details of the individual functions. */ void gfc_conv_expr (gfc_se * se, gfc_expr * expr); void gfc_conv_expr_val (gfc_se * se, gfc_expr * expr); void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr); void gfc_conv_expr_reference (gfc_se * se, gfc_expr *); void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); + /* Find the decl containing the auxiliary variables for assigned variables. */ void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); /* If the value is not constant, Create a temporary and copy the value. */ *************** void gfc_conv_intrinsic_function (gfc_se *** 301,307 **** int gfc_is_intrinsic_libcall (gfc_expr *); /* Also used to CALL subroutines. */ ! void gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *); /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */ /* Generate code for a scalar assignment. */ --- 296,302 ---- int gfc_is_intrinsic_libcall (gfc_expr *); /* Also used to CALL subroutines. */ ! int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *); /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */ /* Generate code for a scalar assignment. */ *************** extern GTY(()) tree gfor_fndecl_stop_num *** 458,463 **** --- 453,459 ---- extern GTY(()) tree gfor_fndecl_stop_string; extern GTY(()) tree gfor_fndecl_select_string; extern GTY(()) tree gfor_fndecl_runtime_error; + extern GTY(()) tree gfor_fndecl_set_std; extern GTY(()) tree gfor_fndecl_in_pack; extern GTY(()) tree gfor_fndecl_in_unpack; extern GTY(()) tree gfor_fndecl_associated; *************** struct lang_decl GTY(()) *** 574,580 **** arg1, arg2) #define build3_v(code, arg1, arg2, arg3) build3(code, void_type_node, \ arg1, arg2, arg3) - - /* flag for alternative return labels. */ - extern int has_alternate_specifier; /* for caller */ #endif /* GFC_TRANS_H */ --- 570,573 ---- diff -Nrcpad gcc-4.0.1/libgfortran/ChangeLog gcc-4.0.2/libgfortran/ChangeLog *** gcc-4.0.1/libgfortran/ChangeLog Thu Jul 7 18:40:18 2005 --- gcc-4.0.2/libgfortran/ChangeLog Wed Sep 21 03:57:56 2005 *************** *** 1,3 **** --- 1,352 ---- + 2005-09-20 Release Manager + + * GCC 4.0.2 released. + + 2005-09-11 Francois-Xavier Coudert + + PR libfortran/19872 + PR libfortran/20179 + * io/unix.c (is_preconnected): Add function to test if a stream + corresponds to a preconnected unit. + * io/io.h: Add prototype for is_preconnected. + * io/transfer.c (data_transfer_init): Truncate overwritten files + on first write, but not preconnected units. + + 2005-09-09 Francois-Xavier Coudert + + PR libfortran/23784 + * io/close.c (st_close): Call library_end even in case of error. + + 2005-09-07 Francois-Xavier Coudert + + PR libfortran/23262 + * acinclude.m4 (LIBGFOR_CHECK_CRLF): New check. + * configure.ac: Use new check. + * configure.in: Regenerate. + * config.h.in: Regenerate. + * configure: Regenerate. + * io/transfer.c (next_record_w): Add case for CRLF as line + terminator. + * io/unix.c (tempfile, regular_file): Open files with + O_BINARY on systems with CRLF. + + 2005-09-07 Steve Ellcey + + PR libfortran/23419 + * io/write.c (extract_int): Use memcpy to access buffer. + (extract_uint): Ditto. + (extract_real): Ditto. + + 2005-09-05 Thomas Koenig + + * io/list_read.c: Adjust size of of value to 32 (to hold + kind=16 complex values). + + 2005-09-04 Thomas Koenig + + PR libfortran/23321 + * io/transfer.c(data_transfer_init): Check for a too-large + record number. Return if sseek failed. + + 2005-09-03 Jakub Jelinek + + * io/read.c (read_x): Take int argument instead of fnode * and + digging the N from F->u.n. + * io/io.h (read_x): Adjust prototype. + * io/transfer.c (formatted_transfer): Adjust callers. Don't clobber + f->u.n for FMT_T. + + 2005-09-02 Francois-Xavier Coudert + + * io/unix.c (stream_ttyname): Protect use of ttyname by + HAVE_TTYNAME macro. + * configure.ac: Add check for ttyname. + * config.h.in: Regenerate. + * configure: Regenerate. + + 2005-09-02 Jakub Jelinek + + PR target/23556 + * io/read.c (convert_real): Fix a typo from last change. + + 2005-09-01 Steve Ellcey + + PR target/23556 + * io/read.c (convert_real): Use memcpy to fill buffer. + (set_integer): Use memcpy to fill buffer. + + 2005-08-29 Thomas Koenig + + PR libfortran/23598 + * io/lock.c(library_start): If ioparm.iostat is present, clear + it unconditionally. + + 2005-08-27 Francois-Xavier Coudert + + * acinclude.m4 (LIBGFOR_CHECK_UNLINK_OPEN_FILE): Add check to see + if target can unlink open files. + * configure.ac: Use this new test. + * config.h.in: Regenerate. + * configure: Regenerate. + * Makefile.in: Regenerate. + * aclocal.ac: Regenerate. + * io/io.h: Add prototype for unpack_filename. + * io/close.c (st_close): Delete file after closing unit if + HAVE_UNLINK_OPEN_FILE is not defined. + * io/unix.c (unpack_filename): Unlink scratch file after opening + it only if HAVE_UNLINK_OPEN_FILE is defined. + + 2005-08-16 Thomas Koenig + + PR libfortran/23428 + * io/transfer.c (iolength_transfer): Return correct length + for inquire(iolength=) for complex variables. + + 2005-08-11 Francois-Xavier Coudert + Steven Bosscher + + PR libfortran/20006 + * Makefile.am: Add file runtime/compile_options.c. + * Makefile.in: Regenerate. + * libgfortran.h: Create structure compile_options_t. Define the + compile_options variable and GFC_STD_ macros. + * runtime/compile_options.c: New file. + * runtime/error.c (notify_std): New function. + * runtime/main.c (init): Call init_compile_options during + initialization. + * io/format.c: Use the new notify_std function for the $ + descriptor extension. + + 2005-08-07 Francois-Xavier Coudert + * Makefile.am: Add file intrinsics/tty.c to Makefile process. + * Makefile.in: Regenerate. + * io/io.h: Prototypes for new functions stream_isatty and + stream_ttyname. + * io/unix (stream_isatty, stream_ttyname): New functions to call + isatty() and ttyname() on a given unit. + * intrinsics/tty.c: New file to implement g77 intrinsics TTYNAM + and ISATTY. + + 2005-08-08 Jerry DeLisle + + PR libfortran/23154 + * io/transfer.c (data_transfer_init): Initialize + current_unit->bytes_left for a read. + + 2005-08-07 Francois-Xavier Coudert + + * io/io.h: Change DEFAULT_TEMPDIR to /tmp instead of /var/tmp. + * io/unix.c (tempfile): Look at the TEMP environment variable + to find the temporary files directory. + + 2005-08-04 Francois-Xavier Coudert + + * io/unix.c: Add O_RDWR to open() call. + + 2005-08-03 Francois-Xavier Coudert + + * libgfortran.h: When isfinite is not provided by the system, + define it as a macro, so that it can accept any floating point + type. + + 2005-08-01 Francois-Xavier Coudert + + PR libfortran/23178 + * intrinsics/flush.c (flush_i8): Add function flush_i8. Update + copyright years. + + 2005-07-30 Paul Thomas + + PR fortran/22570 and related issues. + * transfer.c (formatted_transfer): Make sure that there + really is data present before X- or T- editing. Move all + treatment of tabbing during writes to start of next data + producing format. Suppress incorrect zeroing of bytes_left + in slash formating. Insert int cast for assignment of a + difference of two gfc_offsets. + + 2005-07-23 Jerry DeLisle + + * io/write.c (write_float): Revise output of IEEE exceptional + values to comply with F95 and F2003 standards. + + 2005-07-22 Jerry DeLisle + + PR libfortran/22570 + * io/unit.c (init_units): Replace BLANK_ZERO with + BLANK_UNSPECIFIED. + * io/read.c (next_char): Return a ' ' character when BLANK_ZERO + or BLANK_NULL are active. + (read_decimal): Interpret ' ' character correctly for BZ or BN. + (read_radix): Interpret ' ' character correctly for BZ or BN. + (read_f): Interpret ' ' character correctly for BZ or BN. + + 2005-07-22 Paul Thomas + + PR libfortran/22570 + * read.c (read_x): Correct the condition for doing the + x-editing during formatted input. + * transfer.c (formatted_transfer): Cast offset difference + as int, clean-up arithmetic with new variable, bytes_used, + zero counters for FMT_SLASH, + (data_transfer_init) Zero X- and T-editing counters + unconditionally. + (next_record_w) Zero X- and T-editing counters. + unconditionally. + + 2005-07-19 Thomas Koenig + + Backport from mainline. + PR libfortran/21593 + io/unix.c: Add member special_file to type unix_stream. + (fd_truncate): Don't call ftruncate or chsize if + s refers to a special file. + (fd_to_stream): initialize s->special_file. + + 2005-07-18 Thomas Koenig + + Backport from mainline. + PR libfortran/21333 + * Makefile.am: Add in_pack_c4.c, in_pack_c8.c, in_unpack_c4.c + and in_unpack_c8.c. + * Makefile.in: Regenerate. + * libgfortran.h: Declare internal_pack_c4, internal_pack_c8, + internal_unpack_c4 and internal_unpack_c8. + * m4/in_pack.m4: Use rtype_ccode insteald of rtype_kind + in function name. + Use sizeof (rtype_name) as size for memory allocation. + * m4/in_unpack.m4: Use rtype_ccode insteald of rtype_kind + in function name. + Use sizeof (rtype_name) for calculation of sizes for memcpy. + * runtime/in_pack_generic.c: For real, integer and logical + call internal_pack_4 if size==4 and internal_pack_8 if + size==8. + For complex, call internal_pack_c4 if size==8 and + internal_pack_c8 if size==16. + * runtime/in_unpack_generic.c: For real, integer and logical + call internal_unpack_4 if size==4 and internal_unpack_8 if + size==8. + For complex, call internal_unpack_c4 if size==8 and + internal_unpack_c8 if size==16. + * generated/in_pack_i4.c: Regenerated. + * generated/in_pack_i8.c: Regenerated. + * generated/in_unpack_i4.c: Regenerated. + * generated/in_unpack_i8.c: Regenerated. + * generated/in_pack_c4.c: New file. + * generated/in_pack_c8.c: New file. + * generated/in_unpack_c4.c: New file. + * generated/in_unpack_c8.c: New file. + + 2005-07-17 Thomas Koenig + + Backport from mainline. + PR libfortran/21480 + * m4/reshape.m4: Use sizeof (rtype_name) for sizes to be passed + to reshape_packed. + * generated/reshape_c4.c: Regenerated. + * generated/reshape_c8.c: Regenerated. + * generated/reshape_i4.c: Regenerated. + * generated/reshape_i8.c: Regenerated. + + 2005-07-16 Andrew Pinski + + PR fortran/13257 + * format.c (parse_format_list): Allow an optional comma + between descriptors. + + 2005-07-15 Thomas Koenig + + Backport from mainline. + PR libfortran/21926 + PR libfortran/18857 + * m4/matmul.m4: Correct zeroing of result for non-packed + arrays with lowest stride is one. + Remove incorrect assertions (original patch by pault@gcc.gnu.org). + * generated/matmul_c4.c: Regenerated. + * generated/matmul_c8.c: Regenerated. + * generated/matmul_i4.c: Regenerated. + * generated/matmul_i8.c: Regenerated. + * generated/matmul_r4.c: Regenerated. + * generated/matmul_r8.c: Regenerated. + + 2005-07-14 Thomas Koenig + + Backport from mainline. + PR libfortran/21594 + PR libfortran/22142 + PR libfortran/22144 + * intrinsics/eoshift0.c: If abs(shift) > len, fill the + the whole array with the boundary value, but don't overrun it. + * intrinsics/eoshift2.c: Likewise. + * m4/eoshift1.m4: Likewise. + * m4/eoshift3.m4: Likewise. + * m4/eoshift1.m4: Correct bstride (it needs to be multiplied + by size since it's a char pointer). + * m4/eoshift3.m4: Likewise. + * m4/cshift1.m4: Remove const from argument ret. + Populate return array descriptor if ret->data is NULL. + * m4/eoshift1.m4: Likewise. + * generated/eoshift1_4.c: Regenerated. + * generated/eoshift1_8.c: Regenerated. + * generated/eoshift3_4.c: Regenerated. + * generated/eoshift3_8.c: Regenerated. + + 2005-07-14 David Edelsohn + + Backport from mainline. + PR libgfortran/22412 + * io/write.c (otoa): Bias p by SCRATCH_SIZE, not + sizeof (SCRATCH_SIZE). + (btoa): Same. + + 2005-07-14 Paul Thomas + + PR libfortran/16435 + * transfer.c (formatted_transfer): Correct the problems + with X- and T-editting that caused TLs followed by TRs + to overwrite data, which caused NIST FM908.FOR to fail + on many tests. + (data_transfer_init): Zero X- and T-editting counters at + the start of formatted IO. + * write.c (write_x): Write specified number of skips with + specified number of spaces at the end. + + 2005-07-14 Paul Thomas + + * io/read.c (read_complex): Prevent X formatting during reads + from going beyond EOR to fix NIST fm908.FOR failure. + * io/list_read.c (read_complex): Allow complex data in list- + directed reads to have eols either side of the comma to + fix NIST FM906.FOR failure. + (nml_get_obj_data): Cure warnings about initializer braces. + (namelist_read): Cure warnings about potentially uninitialized pointers. + + 2005-07-12 Feng Wang + + * runtime/string.c (compare0): Remove unused variable. + * intrinsics/etime.c (etime_sub): Ditto. + * intrinsics/getcwd.c (getcwd_i4_sub): Ditto. + * intrinsics/stat.c (stat_i4_sub stat_i8_sub fstat_i4_sub + fstat_i8_sub): Ditto. + * intrinsics/unlink.c (unlink_i4_sub): Ditto. + * io/unit.c (init_units): Ditto. + + Backport from mainline. + 2005-07-07 Feng Wang + PR fortran/16531 + * io/transfer.c (formatted_transfer): Enable FMT_A on other types to + support Hollerith constants. + + 2005-07-10 Jerry DeLisle + + PR libfortran/21875 (FM111.f) + * io/read.c (next_char): Return a ' ' character when BLANK_ZERO or + BLANK_NULL are active. + (read_decimal): Interpret ' ' character correctly for BZ or BN. + (read_radix): Interpret ' ' character correctly for BZ or BN. + (read_f): Interpret ' ' character correctly for BZ or BN. + * gfortran.dg/test (fmt_read_bz_bn.f90): New test case. + 2005-07-07 Release Manager * GCC 4.0.1 released. *************** *** 182,188 **** Change second, independent use of variable dim to srank. 2005-05-23 Thomas Koenig ! Backport from mainline: PR libfortran/21354 PR libfortran/21075 --- 531,537 ---- Change second, independent use of variable dim to srank. 2005-05-23 Thomas Koenig ! Backport from mainline: PR libfortran/21354 PR libfortran/21075 diff -Nrcpad gcc-4.0.1/libgfortran/Makefile.am gcc-4.0.2/libgfortran/Makefile.am *** gcc-4.0.1/libgfortran/Makefile.am Wed Jun 1 23:02:14 2005 --- gcc-4.0.2/libgfortran/Makefile.am Thu Aug 11 13:53:21 2005 *************** intrinsics/symlnk.c \ *** 83,88 **** --- 83,89 ---- intrinsics/system_clock.c \ intrinsics/time.c \ intrinsics/transpose_generic.c \ + intrinsics/tty.c \ intrinsics/umask.c \ intrinsics/unlink.c \ intrinsics/unpack_generic.c \ *************** runtime/in_unpack_generic.c \ *** 91,96 **** --- 92,98 ---- runtime/normalize.c gfor_src= \ + runtime/compile_options.c \ runtime/environ.c \ runtime/error.c \ runtime/main.c \ *************** generated/cshift1_8.c *** 240,250 **** in_pack_c = \ generated/in_pack_i4.c \ ! generated/in_pack_i8.c in_unpack_c = \ generated/in_unpack_i4.c \ ! generated/in_unpack_i8.c i_exponent_c = \ generated/exponent_r4.c \ --- 242,256 ---- in_pack_c = \ generated/in_pack_i4.c \ ! generated/in_pack_i8.c \ ! generated/in_pack_c4.c \ ! generated/in_pack_c8.c in_unpack_c = \ generated/in_unpack_i4.c \ ! generated/in_unpack_i8.c \ ! generated/in_unpack_c4.c \ ! generated/in_unpack_c8.c i_exponent_c = \ generated/exponent_r4.c \ diff -Nrcpad gcc-4.0.1/libgfortran/Makefile.in gcc-4.0.2/libgfortran/Makefile.in *** gcc-4.0.1/libgfortran/Makefile.in Thu Jul 7 20:44:40 2005 --- gcc-4.0.2/libgfortran/Makefile.in Wed Sep 28 06:16:38 2005 *************** *** 1,4 **** ! # Makefile.in generated by automake 1.9.2 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, --- 1,4 ---- ! # Makefile.in generated by automake 1.9.4 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, *************** DIST_COMMON = $(am__configure_deps) $(sr *** 47,54 **** $(top_srcdir)/configure ChangeLog subdir = . ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 ! am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ ! $(top_srcdir)/../libtool.m4 $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ --- 47,56 ---- $(top_srcdir)/configure ChangeLog subdir = . ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 ! am__aclocal_m4_deps = $(top_srcdir)/../config/gcc-version.m4 \ ! $(top_srcdir)/../config/no-executables.m4 \ ! $(top_srcdir)/acinclude.m4 $(top_srcdir)/../libtool.m4 \ ! $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ *************** am__strip_dir = `echo $$p | sed -e 's|^. *** 65,72 **** am__installdirs = "$(DESTDIR)$(toolexeclibdir)" toolexeclibLTLIBRARIES_INSTALL = $(INSTALL) LTLIBRARIES = $(toolexeclib_LTLIBRARIES) ! am__objects_1 = environ.lo error.lo main.lo memory.lo pause.lo stop.lo \ ! string.lo select.lo am__objects_2 = all_l4.lo all_l8.lo am__objects_3 = any_l4.lo any_l8.lo am__objects_4 = count_4_l4.lo count_8_l4.lo count_4_l8.lo \ --- 67,74 ---- am__installdirs = "$(DESTDIR)$(toolexeclibdir)" toolexeclibLTLIBRARIES_INSTALL = $(INSTALL) LTLIBRARIES = $(toolexeclib_LTLIBRARIES) ! am__objects_1 = compile_options.lo environ.lo error.lo main.lo \ ! memory.lo pause.lo stop.lo string.lo select.lo am__objects_2 = all_l4.lo all_l8.lo am__objects_3 = any_l4.lo any_l8.lo am__objects_4 = count_4_l4.lo count_8_l4.lo count_4_l8.lo \ *************** am__objects_21 = eoshift3_4.lo eoshift3_ *** 104,111 **** am__objects_22 = cshift1_4.lo cshift1_8.lo am__objects_23 = reshape_i4.lo reshape_i8.lo reshape_c4.lo \ reshape_c8.lo ! am__objects_24 = in_pack_i4.lo in_pack_i8.lo ! am__objects_25 = in_unpack_i4.lo in_unpack_i8.lo am__objects_26 = exponent_r4.lo exponent_r8.lo am__objects_27 = fraction_r4.lo fraction_r8.lo am__objects_28 = nearest_r4.lo nearest_r8.lo --- 106,115 ---- am__objects_22 = cshift1_4.lo cshift1_8.lo am__objects_23 = reshape_i4.lo reshape_i8.lo reshape_c4.lo \ reshape_c8.lo ! am__objects_24 = in_pack_i4.lo in_pack_i8.lo in_pack_c4.lo \ ! in_pack_c8.lo ! am__objects_25 = in_unpack_i4.lo in_unpack_i8.lo in_unpack_c4.lo \ ! in_unpack_c8.lo am__objects_26 = exponent_r4.lo exponent_r8.lo am__objects_27 = fraction_r4.lo fraction_r8.lo am__objects_28 = nearest_r4.lo nearest_r8.lo *************** am__objects_33 = associated.lo abort.lo *** 135,141 **** spread_generic.lo string_intrinsics.lo system.lo rand.lo \ random.lo rename.lo reshape_generic.lo reshape_packed.lo \ selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \ ! system_clock.lo time.lo transpose_generic.lo umask.lo \ unlink.lo unpack_generic.lo in_pack_generic.lo \ in_unpack_generic.lo normalize.lo am__objects_34 = --- 139,145 ---- spread_generic.lo string_intrinsics.lo system.lo rand.lo \ random.lo rename.lo reshape_generic.lo reshape_packed.lo \ selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \ ! system_clock.lo time.lo transpose_generic.lo tty.lo umask.lo \ unlink.lo unpack_generic.lo in_pack_generic.lo \ in_unpack_generic.lo normalize.lo am__objects_34 = *************** enable_shared = @enable_shared@ *** 275,280 **** --- 279,287 ---- enable_static = @enable_static@ exec_prefix = @exec_prefix@ extra_ldflags_libgfortran = @extra_ldflags_libgfortran@ + gcc_version = @gcc_version@ + gcc_version_full = @gcc_version_full@ + gcc_version_trigger = @gcc_version_trigger@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ *************** intrinsics/symlnk.c \ *** 375,380 **** --- 382,388 ---- intrinsics/system_clock.c \ intrinsics/time.c \ intrinsics/transpose_generic.c \ + intrinsics/tty.c \ intrinsics/umask.c \ intrinsics/unlink.c \ intrinsics/unpack_generic.c \ *************** runtime/in_unpack_generic.c \ *** 383,388 **** --- 391,397 ---- runtime/normalize.c gfor_src = \ + runtime/compile_options.c \ runtime/environ.c \ runtime/error.c \ runtime/main.c \ *************** generated/cshift1_8.c *** 532,542 **** in_pack_c = \ generated/in_pack_i4.c \ ! generated/in_pack_i8.c in_unpack_c = \ generated/in_unpack_i4.c \ ! generated/in_unpack_i8.c i_exponent_c = \ generated/exponent_r4.c \ --- 541,555 ---- in_pack_c = \ generated/in_pack_i4.c \ ! generated/in_pack_i8.c \ ! generated/in_pack_c4.c \ ! generated/in_pack_c8.c in_unpack_c = \ generated/in_unpack_i4.c \ ! generated/in_unpack_i8.c \ ! generated/in_unpack_c4.c \ ! generated/in_unpack_c8.c i_exponent_c = \ generated/exponent_r4.c \ *************** f2c_specifics.lo: intrinsics/f2c_specifi *** 822,827 **** --- 835,843 ---- .c.lo: $(LTCOMPILE) -c -o $@ $< + compile_options.lo: runtime/compile_options.c + $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o compile_options.lo `test -f 'runtime/compile_options.c' || echo '$(srcdir)/'`runtime/compile_options.c + environ.lo: runtime/environ.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o environ.lo `test -f 'runtime/environ.c' || echo '$(srcdir)/'`runtime/environ.c *************** in_pack_i4.lo: generated/in_pack_i4.c *** 1128,1139 **** --- 1144,1167 ---- in_pack_i8.lo: generated/in_pack_i8.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o in_pack_i8.lo `test -f 'generated/in_pack_i8.c' || echo '$(srcdir)/'`generated/in_pack_i8.c + in_pack_c4.lo: generated/in_pack_c4.c + $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o in_pack_c4.lo `test -f 'generated/in_pack_c4.c' || echo '$(srcdir)/'`generated/in_pack_c4.c + + in_pack_c8.lo: generated/in_pack_c8.c + $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o in_pack_c8.lo `test -f 'generated/in_pack_c8.c' || echo '$(srcdir)/'`generated/in_pack_c8.c + in_unpack_i4.lo: generated/in_unpack_i4.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o in_unpack_i4.lo `test -f 'generated/in_unpack_i4.c' || echo '$(srcdir)/'`generated/in_unpack_i4.c in_unpack_i8.lo: generated/in_unpack_i8.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o in_unpack_i8.lo `test -f 'generated/in_unpack_i8.c' || echo '$(srcdir)/'`generated/in_unpack_i8.c + in_unpack_c4.lo: generated/in_unpack_c4.c + $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o in_unpack_c4.lo `test -f 'generated/in_unpack_c4.c' || echo '$(srcdir)/'`generated/in_unpack_c4.c + + in_unpack_c8.lo: generated/in_unpack_c8.c + $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o in_unpack_c8.lo `test -f 'generated/in_unpack_c8.c' || echo '$(srcdir)/'`generated/in_unpack_c8.c + exponent_r4.lo: generated/exponent_r4.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o exponent_r4.lo `test -f 'generated/exponent_r4.c' || echo '$(srcdir)/'`generated/exponent_r4.c *************** time.lo: intrinsics/time.c *** 1368,1373 **** --- 1396,1404 ---- transpose_generic.lo: intrinsics/transpose_generic.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o transpose_generic.lo `test -f 'intrinsics/transpose_generic.c' || echo '$(srcdir)/'`intrinsics/transpose_generic.c + tty.lo: intrinsics/tty.c + $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o tty.lo `test -f 'intrinsics/tty.c' || echo '$(srcdir)/'`intrinsics/tty.c + umask.lo: intrinsics/umask.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o umask.lo `test -f 'intrinsics/umask.c' || echo '$(srcdir)/'`intrinsics/umask.c *************** distclean-tags: *** 1686,1692 **** distdir: $(DISTFILES) $(am__remove_distdir) mkdir $(distdir) ! $(mkdir_p) $(distdir)/.. $(distdir)/m4 @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's|.|.|g'`; \ list='$(DISTFILES)'; for file in $$list; do \ --- 1717,1723 ---- distdir: $(DISTFILES) $(am__remove_distdir) mkdir $(distdir) ! $(mkdir_p) $(distdir)/.. $(distdir)/../config $(distdir)/m4 @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's|.|.|g'`; \ list='$(DISTFILES)'; for file in $$list; do \ diff -Nrcpad gcc-4.0.1/libgfortran/acinclude.m4 gcc-4.0.2/libgfortran/acinclude.m4 *** gcc-4.0.1/libgfortran/acinclude.m4 Sun Dec 12 08:59:01 2004 --- gcc-4.0.2/libgfortran/acinclude.m4 Wed Sep 7 21:31:55 2005 *************** extern void bar(void) __attribute__((ali *** 148,150 **** --- 148,232 ---- AC_DEFINE(HAVE_ATTRIBUTE_ALIAS, 1, [Define to 1 if the target supports __attribute__((alias(...))).]) fi]) + + dnl Check whether target can unlink a file still open. + AC_DEFUN([LIBGFOR_CHECK_UNLINK_OPEN_FILE], [ + AC_CACHE_CHECK([whether the target can unlink an open file], + have_unlink_open_file, [ + AC_TRY_RUN([ + #include + #include + #include + #include + + int main () + { + int fd; + + fd = open ("testfile", O_RDWR | O_CREAT, S_IWRITE | S_IREAD); + if (fd <= 0) + return 0; + if (unlink ("testfile") == -1) + return 1; + write (fd, "This is a test\n", 15); + close (fd); + + if (open ("testfile", O_RDONLY, S_IWRITE | S_IREAD) == -1 && errno == ENOENT) + return 0; + else + return 1; + }], have_unlink_open_file=yes, have_unlink_open_file=no, [ + case "${target}" in + *mingw*) have_unlink_open_file=no ;; + *) have_unlink_open_file=yes;; + esac])]) + if test x"$have_unlink_open_file" = xyes; then + AC_DEFINE(HAVE_UNLINK_OPEN_FILE, 1, [Define if target can unlink open files.]) + fi]) + + dnl Check whether CRLF is the line terminator + AC_DEFUN([LIBGFOR_CHECK_CRLF], [ + AC_CACHE_CHECK([whether the target has CRLF as line terminator], + have_crlf, [ + AC_TRY_RUN([ + /* This test program should exit with status 0 if system uses a CRLF as + line terminator, and status 1 otherwise. + Since it is used to check for mingw systems, and should return 0 in any + other case, in case of a failure we will not use CRLF. */ + #include + #include + #include + #include + + int main () + { + #ifndef O_BINARY + exit(1); + #else + int fd, bytes; + char buff[5]; + + fd = open ("foo", O_WRONLY | O_CREAT | O_TRUNC, S_IRWXU); + if (fd < 0) + exit(1); + if (write (fd, "\n", 1) < 0) + perror ("write"); + + close (fd); + + if ((fd = open ("foo", O_RDONLY | O_BINARY, S_IRWXU)) < 0) + exit(1); + bytes = read (fd, buff, 5); + if (bytes == 2 && buff[0] == '\r' && buff[1] == '\n') + exit(0); + else + exit(1); + #endif + }], have_crlf=yes, have_crlf=no, [ + case "${target}" in + *mingw*) have_crlf=yes ;; + *) have_crlf=no;; + esac])]) + if test x"$have_crlf" = xyes; then + AC_DEFINE(HAVE_CRLF, 1, [Define if CRLF is line terminator.]) + fi]) diff -Nrcpad gcc-4.0.1/libgfortran/aclocal.m4 gcc-4.0.2/libgfortran/aclocal.m4 *** gcc-4.0.1/libgfortran/aclocal.m4 Thu Jul 7 20:44:40 2005 --- gcc-4.0.2/libgfortran/aclocal.m4 Wed Sep 28 06:16:38 2005 *************** *** 1,4 **** ! # generated automatically by aclocal 1.9.2 -*- Autoconf -*- # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 # Free Software Foundation, Inc. --- 1,4 ---- ! # generated automatically by aclocal 1.9.4 -*- Autoconf -*- # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 # Free Software Foundation, Inc. *************** AC_DEFUN([AM_AUTOMAKE_VERSION], [am__api *** 40,46 **** # Call AM_AUTOMAKE_VERSION so it can be traced. # This function is AC_REQUIREd by AC_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], ! [AM_AUTOMAKE_VERSION([1.9.2])]) # AM_AUX_DIR_EXPAND --- 40,46 ---- # Call AM_AUTOMAKE_VERSION so it can be traced. # This function is AC_REQUIREd by AC_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], ! [AM_AUTOMAKE_VERSION([1.9.4])]) # AM_AUX_DIR_EXPAND *************** AC_SUBST([am__tar]) *** 817,820 **** --- 817,822 ---- AC_SUBST([am__untar]) ]) # _AM_PROG_TAR + m4_include([../config/gcc-version.m4]) + m4_include([../config/no-executables.m4]) m4_include([acinclude.m4]) diff -Nrcpad gcc-4.0.1/libgfortran/config.h.in gcc-4.0.2/libgfortran/config.h.in *** gcc-4.0.1/libgfortran/config.h.in Wed Jun 15 18:53:23 2005 --- gcc-4.0.2/libgfortran/config.h.in Wed Sep 7 21:31:55 2005 *************** *** 45,50 **** --- 45,53 ---- /* libm includes coshf */ #undef HAVE_COSHF + /* Define if CRLF is line terminator. */ + #undef HAVE_CRLF + /* libm includes erf */ #undef HAVE_ERF *************** *** 273,281 **** --- 276,290 ---- /* libm includes truncf */ #undef HAVE_TRUNCF + /* Define to 1 if you have the `ttyname' function. */ + #undef HAVE_TTYNAME + /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H + /* Define if target can unlink open files. */ + #undef HAVE_UNLINK_OPEN_FILE + /* libm includes y0 */ #undef HAVE_Y0 diff -Nrcpad gcc-4.0.1/libgfortran/configure gcc-4.0.2/libgfortran/configure *** gcc-4.0.1/libgfortran/configure Thu Jul 7 20:44:40 2005 --- gcc-4.0.2/libgfortran/configure Wed Sep 28 06:16:38 2005 *************** esac *** 970,976 **** else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi ! cd $ac_popdir done fi --- 970,976 ---- else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi ! cd "$ac_popdir" done fi *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 2619,2626 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 2619,2625 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 2678,2685 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 2677,2683 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 2795,2802 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 2793,2799 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 2850,2857 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 2847,2853 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 2896,2903 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 2892,2898 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 2941,2948 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 2936,2942 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** test x"$pic_mode" = xno && libtool_flags *** 4079,4085 **** case $host in *-*-irix6*) # Find out which ABI we are using. ! echo '#line 4082 "configure"' > conftest.$ac_ext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>&5 ac_status=$? --- 4073,4079 ---- case $host in *-*-irix6*) # Find out which ABI we are using. ! echo '#line 4076 "configure"' > conftest.$ac_ext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 4226,4233 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 4220,4226 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** fi *** 4470,4476 **** # Provide some information about the compiler. ! echo "$as_me:4473:" \ "checking for Fortran compiler version" >&5 ac_compiler=`set X $ac_compile; echo $2` { (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 --- 4463,4469 ---- # Provide some information about the compiler. ! echo "$as_me:4466:" \ "checking for Fortran compiler version" >&5 ac_compiler=`set X $ac_compile; echo $2` { (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 4516,4523 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_fc_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 4509,4515 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_fc_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 4566,4573 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_fc_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 4558,4564 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_fc_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 4674,4681 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 4665,4671 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 4704,4711 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 4694,4700 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 4775,4782 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 4764,4770 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 4828,4835 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 4816,4822 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 4900,4907 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 4887,4893 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 4953,4960 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 4939,4945 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 5277,5284 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 5262,5268 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 5448,5455 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 5432,5438 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 5517,5524 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 5500,5506 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 5707,5714 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 5689,5695 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 5948,5955 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 5929,5935 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 6017,6024 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 5997,6003 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 6190,6197 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 6169,6175 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 6344,6351 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 6322,6328 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 6497,6504 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 6474,6480 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 6643,6650 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 6619,6625 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 6791,6798 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 6766,6772 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 6835,6842 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 6809,6815 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 6901,6908 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 6874,6880 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 6945,6952 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 6917,6923 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 7011,7018 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 6982,6988 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 7055,7062 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7025,7031 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7135,7142 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7104,7110 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7249,7256 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7217,7223 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7363,7370 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7330,7336 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** done *** 7398,7404 **** ! for ac_func in sleep time do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 --- 7364,7371 ---- ! ! for ac_func in sleep time ttyname do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7471,7478 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7438,7444 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7549,7556 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7515,7521 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7626,7633 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7591,7597 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7703,7710 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7667,7673 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7783,7790 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7746,7752 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7860,7867 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7822,7828 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 7937,7944 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7898,7904 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8014,8021 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 7974,7980 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8091,8098 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8050,8056 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8168,8175 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8126,8132 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8245,8252 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8202,8208 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8322,8329 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8278,8284 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8399,8406 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8354,8360 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8476,8483 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8430,8436 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8553,8560 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8506,8512 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8630,8637 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8582,8588 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8707,8714 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8658,8664 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8784,8791 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8734,8740 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8861,8868 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8810,8816 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 8938,8945 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8886,8892 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9015,9022 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 8962,8968 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9092,9099 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9038,9044 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9169,9176 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9114,9120 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9246,9253 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9190,9196 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9323,9330 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9266,9272 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9400,9407 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9342,9348 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9477,9484 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9418,9424 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9554,9561 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9494,9500 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9631,9638 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9570,9576 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9708,9715 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9646,9652 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9785,9792 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9722,9728 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9862,9869 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9798,9804 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 9939,9946 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9874,9880 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10016,10023 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 9950,9956 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10093,10100 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10026,10032 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10170,10177 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10102,10108 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10247,10254 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10178,10184 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10324,10331 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10254,10260 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10401,10408 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10330,10336 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10478,10485 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10406,10412 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10555,10562 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10482,10488 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10632,10639 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10558,10564 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10709,10716 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10634,10640 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10786,10793 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10710,10716 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10863,10870 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10786,10792 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 10940,10947 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10862,10868 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 11017,11024 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 10938,10944 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 11094,11101 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11014,11020 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 11171,11178 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11090,11096 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 11250,11257 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11168,11174 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 11336,11343 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11253,11259 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 11443,11450 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11359,11365 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 11506,11513 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11421,11427 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 11645,11652 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11559,11565 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 11724,11731 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11637,11643 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 11793,11800 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11705,11711 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_c *** 11858,11865 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11769,11775 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** if { (eval echo "$as_me:$LINENO: \"$ac_l *** 11931,11938 **** cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" ! || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? --- 11841,11847 ---- cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && ! { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? *************** _ACEOF *** 11964,11969 **** --- 11873,12046 ---- fi + # Various other checks on target + + echo "$as_me:$LINENO: checking whether the target can unlink an open file" >&5 + echo $ECHO_N "checking whether the target can unlink an open file... $ECHO_C" >&6 + if test "${have_unlink_open_file+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + + if test "$cross_compiling" = yes; then + + case "${target}" in + *mingw*) have_unlink_open_file=no ;; + *) have_unlink_open_file=yes;; + esac + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + #include + #include + #include + #include + + int main () + { + int fd; + + fd = open ("testfile", O_RDWR | O_CREAT, S_IWRITE | S_IREAD); + if (fd <= 0) + return 0; + if (unlink ("testfile") == -1) + return 1; + write (fd, "This is a test\n", 15); + close (fd); + + if (open ("testfile", O_RDONLY, S_IWRITE | S_IREAD) == -1 && errno == ENOENT) + return 0; + else + return 1; + } + _ACEOF + rm -f conftest$ac_exeext + if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + have_unlink_open_file=yes + else + echo "$as_me: program exited with status $ac_status" >&5 + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ( exit $ac_status ) + have_unlink_open_file=no + fi + rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext + fi + fi + echo "$as_me:$LINENO: result: $have_unlink_open_file" >&5 + echo "${ECHO_T}$have_unlink_open_file" >&6 + if test x"$have_unlink_open_file" = xyes; then + + cat >>confdefs.h <<\_ACEOF + #define HAVE_UNLINK_OPEN_FILE 1 + _ACEOF + + fi + + # Check whether line terminator is LF or CRLF + + echo "$as_me:$LINENO: checking whether the target has CRLF as line terminator" >&5 + echo $ECHO_N "checking whether the target has CRLF as line terminator... $ECHO_C" >&6 + if test "${have_crlf+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 + else + + if test "$cross_compiling" = yes; then + + case "${target}" in + *mingw*) have_crlf=yes ;; + *) have_crlf=no;; + esac + else + cat >conftest.$ac_ext <<_ACEOF + /* confdefs.h. */ + _ACEOF + cat confdefs.h >>conftest.$ac_ext + cat >>conftest.$ac_ext <<_ACEOF + /* end confdefs.h. */ + + /* This test program should exit with status 0 if system uses a CRLF as + line terminator, and status 1 otherwise. + Since it is used to check for mingw systems, and should return 0 in any + other case, in case of a failure we will not use CRLF. */ + #include + #include + #include + #include + + int main () + { + #ifndef O_BINARY + exit(1); + #else + int fd, bytes; + char buff[5]; + + fd = open ("foo", O_WRONLY | O_CREAT | O_TRUNC, S_IRWXU); + if (fd < 0) + exit(1); + if (write (fd, "\n", 1) < 0) + perror ("write"); + + close (fd); + + if ((fd = open ("foo", O_RDONLY | O_BINARY, S_IRWXU)) < 0) + exit(1); + bytes = read (fd, buff, 5); + if (bytes == 2 && buff[0] == '\r' && buff[1] == '\n') + exit(0); + else + exit(1); + #endif + } + _ACEOF + rm -f conftest$ac_exeext + if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + have_crlf=yes + else + echo "$as_me: program exited with status $ac_status" >&5 + echo "$as_me: failed program was:" >&5 + sed 's/^/| /' conftest.$ac_ext >&5 + + ( exit $ac_status ) + have_crlf=no + fi + rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext + fi + fi + echo "$as_me:$LINENO: result: $have_crlf" >&5 + echo "${ECHO_T}$have_crlf" >&6 + if test x"$have_crlf" = xyes; then + + cat >>confdefs.h <<\_ACEOF + #define HAVE_CRLF 1 + _ACEOF + + fi + cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure *************** esac *** 12904,12914 **** *) ac_INSTALL=$ac_top_builddir$INSTALL ;; esac - if test x"$ac_file" != x-; then - { echo "$as_me:$LINENO: creating $ac_file" >&5 - echo "$as_me: creating $ac_file" >&6;} - rm -f "$ac_file" - fi # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ --- 12981,12986 ---- *************** echo "$as_me: error: cannot find input f *** 12947,12952 **** --- 13019,13030 ---- fi;; esac done` || { (exit 1); exit 1; } + + if test x"$ac_file" != x-; then + { echo "$as_me:$LINENO: creating $ac_file" >&5 + echo "$as_me: creating $ac_file" >&6;} + rm -f "$ac_file" + fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF sed "$ac_vpsub diff -Nrcpad gcc-4.0.1/libgfortran/configure.ac gcc-4.0.2/libgfortran/configure.ac *** gcc-4.0.1/libgfortran/configure.ac Wed Jun 15 18:53:25 2005 --- gcc-4.0.2/libgfortran/configure.ac Wed Sep 7 21:31:56 2005 *************** AC_CHECK_LIB([m],[csin],[need_math="no"] *** 173,179 **** # Check for library functions. AC_CHECK_FUNCS(getrusage times mkstemp strtof snprintf ftruncate chsize) AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror) ! AC_CHECK_FUNCS(sleep time) # Check libc for getgid, getpid, getuid AC_CHECK_LIB([c],[getgid],[AC_DEFINE([HAVE_GETGID],[1],[libc includes getgid])]) --- 173,179 ---- # Check for library functions. AC_CHECK_FUNCS(getrusage times mkstemp strtof snprintf ftruncate chsize) AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror) ! AC_CHECK_FUNCS(sleep time ttyname) # Check libc for getgid, getpid, getuid AC_CHECK_LIB([c],[getgid],[AC_DEFINE([HAVE_GETGID],[1],[libc includes getgid])]) *************** LIBGFOR_CHECK_ATTRIBUTE_VISIBILITY *** 256,261 **** --- 256,267 ---- LIBGFOR_CHECK_ATTRIBUTE_DLLEXPORT LIBGFOR_CHECK_ATTRIBUTE_ALIAS + # Various other checks on target + LIBGFOR_CHECK_UNLINK_OPEN_FILE + + # Check whether line terminator is LF or CRLF + LIBGFOR_CHECK_CRLF + AC_CACHE_SAVE if test ${multilib} = yes; then diff -Nrcpad gcc-4.0.1/libgfortran/generated/cshift1_4.c gcc-4.0.2/libgfortran/generated/cshift1_4.c *** gcc-4.0.1/libgfortran/generated/cshift1_4.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/cshift1_4.c Thu Jul 14 21:17:21 2005 *************** Boston, MA 02111-1307, USA. */ *** 34,46 **** #include #include "libgfortran.h" ! void cshift1_4 (const gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich); export_proto(cshift1_4); void ! cshift1_4 (const gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich) { --- 34,46 ---- #include #include "libgfortran.h" ! void cshift1_4 (gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich); export_proto(cshift1_4); void ! cshift1_4 (gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i4 * h, const GFC_INTEGER_4 * pwhich) { *************** cshift1_4 (const gfc_array_char * ret, *** 80,85 **** --- 80,104 ---- size = GFC_DESCRIPTOR_SIZE (ret); + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->base = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + extent[0] = 1; count[0] = 0; size = GFC_DESCRIPTOR_SIZE (array); diff -Nrcpad gcc-4.0.1/libgfortran/generated/cshift1_8.c gcc-4.0.2/libgfortran/generated/cshift1_8.c *** gcc-4.0.1/libgfortran/generated/cshift1_8.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/cshift1_8.c Thu Jul 14 21:17:21 2005 *************** Boston, MA 02111-1307, USA. */ *** 34,46 **** #include #include "libgfortran.h" ! void cshift1_8 (const gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich); export_proto(cshift1_8); void ! cshift1_8 (const gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich) { --- 34,46 ---- #include #include "libgfortran.h" ! void cshift1_8 (gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich); export_proto(cshift1_8); void ! cshift1_8 (gfc_array_char * ret, const gfc_array_char * array, const gfc_array_i8 * h, const GFC_INTEGER_8 * pwhich) { *************** cshift1_8 (const gfc_array_char * ret, *** 80,85 **** --- 80,104 ---- size = GFC_DESCRIPTOR_SIZE (ret); + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->base = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + extent[0] = 1; count[0] = 0; size = GFC_DESCRIPTOR_SIZE (array); diff -Nrcpad gcc-4.0.1/libgfortran/generated/eoshift1_4.c gcc-4.0.2/libgfortran/generated/eoshift1_4.c *** gcc-4.0.1/libgfortran/generated/eoshift1_4.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/eoshift1_4.c Thu Jul 14 21:17:21 2005 *************** Boston, MA 02111-1307, USA. */ *** 37,50 **** static const char zeros[16] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; ! extern void eoshift1_4 (const gfc_array_char *, const gfc_array_char *, const gfc_array_i4 *, const char *, const GFC_INTEGER_4 *); export_proto(eoshift1_4); void ! eoshift1_4 (const gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i4 *h, const char *pbound, const GFC_INTEGER_4 *pwhich) --- 37,50 ---- static const char zeros[16] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; ! extern void eoshift1_4 (gfc_array_char *, const gfc_array_char *, const gfc_array_i4 *, const char *, const GFC_INTEGER_4 *); export_proto(eoshift1_4); void ! eoshift1_4 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i4 *h, const char *pbound, const GFC_INTEGER_4 *pwhich) *************** eoshift1_4 (const gfc_array_char *ret, *** 89,94 **** --- 89,114 ---- extent[0] = 1; count[0] = 0; size = GFC_DESCRIPTOR_SIZE (array); + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->base = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + n = 0; for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) { *************** eoshift1_4 (const gfc_array_char *ret, *** 109,115 **** rstride[n] = ret->dim[dim].stride * size; sstride[n] = array->dim[dim].stride * size; ! hstride[n] = h->dim[n].stride; n++; } } --- 129,135 ---- rstride[n] = ret->dim[dim].stride * size; sstride[n] = array->dim[dim].stride * size; ! hstride[n] = h->dim[n].stride * size; n++; } } *************** eoshift1_4 (const gfc_array_char *ret, *** 132,138 **** { /* Do the shift for this dimension. */ sh = *hptr; ! delta = (sh >= 0) ? sh: -sh; if (sh > 0) { src = &sptr[delta * soffset]; --- 152,165 ---- { /* Do the shift for this dimension. */ sh = *hptr; ! if (( sh >= 0 ? sh : -sh ) > len) ! { ! delta = len; ! sh = len; ! } ! else ! delta = (sh >= 0) ? sh: -sh; ! if (sh > 0) { src = &sptr[delta * soffset]; diff -Nrcpad gcc-4.0.1/libgfortran/generated/eoshift1_8.c gcc-4.0.2/libgfortran/generated/eoshift1_8.c *** gcc-4.0.1/libgfortran/generated/eoshift1_8.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/eoshift1_8.c Thu Jul 14 21:17:21 2005 *************** Boston, MA 02111-1307, USA. */ *** 37,50 **** static const char zeros[16] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; ! extern void eoshift1_8 (const gfc_array_char *, const gfc_array_char *, const gfc_array_i8 *, const char *, const GFC_INTEGER_8 *); export_proto(eoshift1_8); void ! eoshift1_8 (const gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i8 *h, const char *pbound, const GFC_INTEGER_8 *pwhich) --- 37,50 ---- static const char zeros[16] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; ! extern void eoshift1_8 (gfc_array_char *, const gfc_array_char *, const gfc_array_i8 *, const char *, const GFC_INTEGER_8 *); export_proto(eoshift1_8); void ! eoshift1_8 (gfc_array_char *ret, const gfc_array_char *array, const gfc_array_i8 *h, const char *pbound, const GFC_INTEGER_8 *pwhich) *************** eoshift1_8 (const gfc_array_char *ret, *** 89,94 **** --- 89,114 ---- extent[0] = 1; count[0] = 0; size = GFC_DESCRIPTOR_SIZE (array); + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->base = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + n = 0; for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) { *************** eoshift1_8 (const gfc_array_char *ret, *** 109,115 **** rstride[n] = ret->dim[dim].stride * size; sstride[n] = array->dim[dim].stride * size; ! hstride[n] = h->dim[n].stride; n++; } } --- 129,135 ---- rstride[n] = ret->dim[dim].stride * size; sstride[n] = array->dim[dim].stride * size; ! hstride[n] = h->dim[n].stride * size; n++; } } *************** eoshift1_8 (const gfc_array_char *ret, *** 132,138 **** { /* Do the shift for this dimension. */ sh = *hptr; ! delta = (sh >= 0) ? sh: -sh; if (sh > 0) { src = &sptr[delta * soffset]; --- 152,165 ---- { /* Do the shift for this dimension. */ sh = *hptr; ! if (( sh >= 0 ? sh : -sh ) > len) ! { ! delta = len; ! sh = len; ! } ! else ! delta = (sh >= 0) ? sh: -sh; ! if (sh > 0) { src = &sptr[delta * soffset]; diff -Nrcpad gcc-4.0.1/libgfortran/generated/eoshift3_4.c gcc-4.0.2/libgfortran/generated/eoshift3_4.c *** gcc-4.0.1/libgfortran/generated/eoshift3_4.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/eoshift3_4.c Thu Jul 14 21:17:21 2005 *************** eoshift3_4 (gfc_array_char *ret, gfc_arr *** 84,89 **** --- 84,108 ---- which = 0; size = GFC_DESCRIPTOR_SIZE (ret); + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->base = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + extent[0] = 1; count[0] = 0; *************** eoshift3_4 (gfc_array_char *ret, gfc_arr *** 110,116 **** hstride[n] = h->dim[n].stride; if (bound) ! bstride[n] = bound->dim[n].stride; else bstride[n] = 0; n++; --- 129,135 ---- hstride[n] = h->dim[n].stride; if (bound) ! bstride[n] = bound->dim[n].stride * size; else bstride[n] = 0; n++; *************** eoshift3_4 (gfc_array_char *ret, gfc_arr *** 142,148 **** { /* Do the shift for this dimension. */ sh = *hptr; ! delta = (sh >= 0) ? sh: -sh; if (sh > 0) { src = &sptr[delta * soffset]; --- 161,174 ---- { /* Do the shift for this dimension. */ sh = *hptr; ! if (( sh >= 0 ? sh : -sh ) > len) ! { ! delta = len; ! sh = len; ! } ! else ! delta = (sh >= 0) ? sh: -sh; ! if (sh > 0) { src = &sptr[delta * soffset]; diff -Nrcpad gcc-4.0.1/libgfortran/generated/eoshift3_8.c gcc-4.0.2/libgfortran/generated/eoshift3_8.c *** gcc-4.0.1/libgfortran/generated/eoshift3_8.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/eoshift3_8.c Thu Jul 14 21:17:21 2005 *************** eoshift3_8 (gfc_array_char *ret, gfc_arr *** 84,89 **** --- 84,108 ---- which = 0; size = GFC_DESCRIPTOR_SIZE (ret); + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->base = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + extent[0] = 1; count[0] = 0; *************** eoshift3_8 (gfc_array_char *ret, gfc_arr *** 110,116 **** hstride[n] = h->dim[n].stride; if (bound) ! bstride[n] = bound->dim[n].stride; else bstride[n] = 0; n++; --- 129,135 ---- hstride[n] = h->dim[n].stride; if (bound) ! bstride[n] = bound->dim[n].stride * size; else bstride[n] = 0; n++; *************** eoshift3_8 (gfc_array_char *ret, gfc_arr *** 142,148 **** { /* Do the shift for this dimension. */ sh = *hptr; ! delta = (sh >= 0) ? sh: -sh; if (sh > 0) { src = &sptr[delta * soffset]; --- 161,174 ---- { /* Do the shift for this dimension. */ sh = *hptr; ! if (( sh >= 0 ? sh : -sh ) > len) ! { ! delta = len; ! sh = len; ! } ! else ! delta = (sh >= 0) ? sh: -sh; ! if (sh > 0) { src = &sptr[delta * soffset]; diff -Nrcpad gcc-4.0.1/libgfortran/generated/in_pack_c4.c gcc-4.0.2/libgfortran/generated/in_pack_c4.c *** gcc-4.0.1/libgfortran/generated/in_pack_c4.c Thu Jan 1 00:00:00 1970 --- gcc-4.0.2/libgfortran/generated/in_pack_c4.c Mon Jul 18 17:40:44 2005 *************** *** 0 **** --- 1,123 ---- + /* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + + This file is part of the GNU Fortran 95 runtime library (libgfortran). + + Libgfortran is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + In addition to the permissions in the GNU General Public License, the + Free Software Foundation gives you unlimited permission to link the + compiled version of this file into combinations with other programs, + and to distribute those combinations without any restriction coming + from the use of this file. (The General Public License restrictions + do apply in other respects; for example, they cover modification of + the file, and distribution when not linked into a combine + executable.) + + Libgfortran is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with libgfortran; see the file COPYING. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + + #include "config.h" + #include + #include + #include "libgfortran.h" + + /* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + + GFC_COMPLEX_4 * + internal_pack_c4 (gfc_array_c4 * source) + { + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type ssize; + const GFC_COMPLEX_4 *src; + GFC_COMPLEX_4 *dest; + GFC_COMPLEX_4 *destptr; + int n; + int packed; + + if (source->dim[0].stride == 0) + { + source->dim[0].stride = 1; + return source->data; + } + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = source->dim[n].stride; + extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (extent[n] <= 0) + { + /* Do nothing. */ + packed = 1; + break; + } + + if (ssize != stride[n]) + packed = 0; + + ssize *= extent[n]; + } + + if (packed) + return source->data; + + /* Allocate storage for the destination. */ + destptr = (GFC_COMPLEX_4 *)internal_malloc_size (ssize * sizeof (GFC_COMPLEX_4)); + dest = destptr; + src = source->data; + stride0 = stride[0]; + + + while (src) + { + /* Copy the data. */ + *(dest++) = *src; + /* Advance to the next element. */ + src += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + src -= stride[n] * extent[n]; + n++; + if (n == dim) + { + src = NULL; + break; + } + else + { + count[n]++; + src += stride[n]; + } + } + } + return destptr; + } + diff -Nrcpad gcc-4.0.1/libgfortran/generated/in_pack_c8.c gcc-4.0.2/libgfortran/generated/in_pack_c8.c *** gcc-4.0.1/libgfortran/generated/in_pack_c8.c Thu Jan 1 00:00:00 1970 --- gcc-4.0.2/libgfortran/generated/in_pack_c8.c Mon Jul 18 17:40:44 2005 *************** *** 0 **** --- 1,123 ---- + /* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + + This file is part of the GNU Fortran 95 runtime library (libgfortran). + + Libgfortran is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + In addition to the permissions in the GNU General Public License, the + Free Software Foundation gives you unlimited permission to link the + compiled version of this file into combinations with other programs, + and to distribute those combinations without any restriction coming + from the use of this file. (The General Public License restrictions + do apply in other respects; for example, they cover modification of + the file, and distribution when not linked into a combine + executable.) + + Libgfortran is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with libgfortran; see the file COPYING. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + + #include "config.h" + #include + #include + #include "libgfortran.h" + + /* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + + GFC_COMPLEX_8 * + internal_pack_c8 (gfc_array_c8 * source) + { + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type ssize; + const GFC_COMPLEX_8 *src; + GFC_COMPLEX_8 *dest; + GFC_COMPLEX_8 *destptr; + int n; + int packed; + + if (source->dim[0].stride == 0) + { + source->dim[0].stride = 1; + return source->data; + } + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = source->dim[n].stride; + extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (extent[n] <= 0) + { + /* Do nothing. */ + packed = 1; + break; + } + + if (ssize != stride[n]) + packed = 0; + + ssize *= extent[n]; + } + + if (packed) + return source->data; + + /* Allocate storage for the destination. */ + destptr = (GFC_COMPLEX_8 *)internal_malloc_size (ssize * sizeof (GFC_COMPLEX_8)); + dest = destptr; + src = source->data; + stride0 = stride[0]; + + + while (src) + { + /* Copy the data. */ + *(dest++) = *src; + /* Advance to the next element. */ + src += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + src -= stride[n] * extent[n]; + n++; + if (n == dim) + { + src = NULL; + break; + } + else + { + count[n]++; + src += stride[n]; + } + } + } + return destptr; + } + diff -Nrcpad gcc-4.0.1/libgfortran/generated/in_pack_i4.c gcc-4.0.2/libgfortran/generated/in_pack_i4.c *** gcc-4.0.1/libgfortran/generated/in_pack_i4.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/in_pack_i4.c Mon Jul 18 17:40:44 2005 *************** internal_pack_4 (gfc_array_i4 * source) *** 82,88 **** return source->data; /* Allocate storage for the destination. */ ! destptr = (GFC_INTEGER_4 *)internal_malloc_size (ssize * 4); dest = destptr; src = source->data; stride0 = stride[0]; --- 82,88 ---- return source->data; /* Allocate storage for the destination. */ ! destptr = (GFC_INTEGER_4 *)internal_malloc_size (ssize * sizeof (GFC_INTEGER_4)); dest = destptr; src = source->data; stride0 = stride[0]; diff -Nrcpad gcc-4.0.1/libgfortran/generated/in_pack_i8.c gcc-4.0.2/libgfortran/generated/in_pack_i8.c *** gcc-4.0.1/libgfortran/generated/in_pack_i8.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/in_pack_i8.c Mon Jul 18 17:40:44 2005 *************** internal_pack_8 (gfc_array_i8 * source) *** 82,88 **** return source->data; /* Allocate storage for the destination. */ ! destptr = (GFC_INTEGER_8 *)internal_malloc_size (ssize * 8); dest = destptr; src = source->data; stride0 = stride[0]; --- 82,88 ---- return source->data; /* Allocate storage for the destination. */ ! destptr = (GFC_INTEGER_8 *)internal_malloc_size (ssize * sizeof (GFC_INTEGER_8)); dest = destptr; src = source->data; stride0 = stride[0]; diff -Nrcpad gcc-4.0.1/libgfortran/generated/in_unpack_c4.c gcc-4.0.2/libgfortran/generated/in_unpack_c4.c *** gcc-4.0.1/libgfortran/generated/in_unpack_c4.c Thu Jan 1 00:00:00 1970 --- gcc-4.0.2/libgfortran/generated/in_unpack_c4.c Mon Jul 18 17:40:44 2005 *************** *** 0 **** --- 1,111 ---- + /* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + + This file is part of the GNU Fortran 95 runtime library (libgfortran). + + Libgfortran is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + In addition to the permissions in the GNU General Public License, the + Free Software Foundation gives you unlimited permission to link the + compiled version of this file into combinations with other programs, + and to distribute those combinations without any restriction coming + from the use of this file. (The General Public License restrictions + do apply in other respects; for example, they cover modification of + the file, and distribution when not linked into a combine + executable.) + + Libgfortran is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with libgfortran; see the file COPYING. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + + #include "config.h" + #include + #include + #include + #include "libgfortran.h" + + void + internal_unpack_c4 (gfc_array_c4 * d, const GFC_COMPLEX_4 * src) + { + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type dsize; + GFC_COMPLEX_4 *dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + if (d->dim[0].stride == 0) + d->dim[0].stride = 1; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = d->dim[n].stride; + extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound; + if (extent[n] <= 0) + abort (); + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_COMPLEX_4)); + return; + } + + stride0 = stride[0]; + + while (dest) + { + /* Copy the data. */ + *dest = *(src++); + /* Advance to the next element. */ + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + dest -= stride[n] * extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n]; + } + } + } + } + diff -Nrcpad gcc-4.0.1/libgfortran/generated/in_unpack_c8.c gcc-4.0.2/libgfortran/generated/in_unpack_c8.c *** gcc-4.0.1/libgfortran/generated/in_unpack_c8.c Thu Jan 1 00:00:00 1970 --- gcc-4.0.2/libgfortran/generated/in_unpack_c8.c Mon Jul 18 17:40:44 2005 *************** *** 0 **** --- 1,111 ---- + /* Helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + + This file is part of the GNU Fortran 95 runtime library (libgfortran). + + Libgfortran is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + In addition to the permissions in the GNU General Public License, the + Free Software Foundation gives you unlimited permission to link the + compiled version of this file into combinations with other programs, + and to distribute those combinations without any restriction coming + from the use of this file. (The General Public License restrictions + do apply in other respects; for example, they cover modification of + the file, and distribution when not linked into a combine + executable.) + + Libgfortran is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with libgfortran; see the file COPYING. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + + #include "config.h" + #include + #include + #include + #include "libgfortran.h" + + void + internal_unpack_c8 (gfc_array_c8 * d, const GFC_COMPLEX_8 * src) + { + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + index_type dsize; + GFC_COMPLEX_8 *dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + if (d->dim[0].stride == 0) + d->dim[0].stride = 1; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = d->dim[n].stride; + extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound; + if (extent[n] <= 0) + abort (); + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_COMPLEX_8)); + return; + } + + stride0 = stride[0]; + + while (dest) + { + /* Copy the data. */ + *dest = *(src++); + /* Advance to the next element. */ + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + dest -= stride[n] * extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n]; + } + } + } + } + diff -Nrcpad gcc-4.0.1/libgfortran/generated/in_unpack_i4.c gcc-4.0.2/libgfortran/generated/in_unpack_i4.c *** gcc-4.0.1/libgfortran/generated/in_unpack_i4.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/in_unpack_i4.c Mon Jul 18 17:40:44 2005 *************** internal_unpack_4 (gfc_array_i4 * d, con *** 71,77 **** if (dsize != 0) { ! memcpy (dest, src, dsize * 4); return; } --- 71,77 ---- if (dsize != 0) { ! memcpy (dest, src, dsize * sizeof (GFC_INTEGER_4)); return; } diff -Nrcpad gcc-4.0.1/libgfortran/generated/in_unpack_i8.c gcc-4.0.2/libgfortran/generated/in_unpack_i8.c *** gcc-4.0.1/libgfortran/generated/in_unpack_i8.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/in_unpack_i8.c Mon Jul 18 17:40:44 2005 *************** internal_unpack_8 (gfc_array_i8 * d, con *** 71,77 **** if (dsize != 0) { ! memcpy (dest, src, dsize * 8); return; } --- 71,77 ---- if (dsize != 0) { ! memcpy (dest, src, dsize * sizeof (GFC_INTEGER_8)); return; } diff -Nrcpad gcc-4.0.1/libgfortran/generated/matmul_c4.c gcc-4.0.2/libgfortran/generated/matmul_c4.c *** gcc-4.0.1/libgfortran/generated/matmul_c4.c Wed Jan 12 21:27:32 2005 --- gcc-4.0.2/libgfortran/generated/matmul_c4.c Fri Jul 15 20:47:33 2005 *************** matmul_c4 (gfc_array_c4 * retarray, gfc_ *** 167,176 **** ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } - assert (a->base == 0); - assert (b->base == 0); - assert (retarray->base == 0); - abase = a->data; bbase = b->data; dest = retarray->data; --- 167,172 ---- *************** matmul_c4 (gfc_array_c4 * retarray, gfc_ *** 182,188 **** GFC_COMPLEX_4 *abase_n; GFC_COMPLEX_4 bbase_yn; ! memset (dest, 0, (sizeof (GFC_COMPLEX_4) * size0(retarray))); for (y = 0; y < ycount; y++) { --- 178,191 ---- GFC_COMPLEX_4 *abase_n; GFC_COMPLEX_4 bbase_yn; ! if (rystride == ycount) ! memset (dest, 0, (sizeof (GFC_COMPLEX_4) * size0((array_t *) retarray))); ! else ! { ! for (y = 0; y < ycount; y++) ! for (x = 0; x < xcount; x++) ! dest[x + y*rystride] = (GFC_COMPLEX_4)0; ! } for (y = 0; y < ycount; y++) { diff -Nrcpad gcc-4.0.1/libgfortran/generated/matmul_c8.c gcc-4.0.2/libgfortran/generated/matmul_c8.c *** gcc-4.0.1/libgfortran/generated/matmul_c8.c Wed Jan 12 21:27:32 2005 --- gcc-4.0.2/libgfortran/generated/matmul_c8.c Fri Jul 15 20:47:34 2005 *************** matmul_c8 (gfc_array_c8 * retarray, gfc_ *** 167,176 **** ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } - assert (a->base == 0); - assert (b->base == 0); - assert (retarray->base == 0); - abase = a->data; bbase = b->data; dest = retarray->data; --- 167,172 ---- *************** matmul_c8 (gfc_array_c8 * retarray, gfc_ *** 182,188 **** GFC_COMPLEX_8 *abase_n; GFC_COMPLEX_8 bbase_yn; ! memset (dest, 0, (sizeof (GFC_COMPLEX_8) * size0(retarray))); for (y = 0; y < ycount; y++) { --- 178,191 ---- GFC_COMPLEX_8 *abase_n; GFC_COMPLEX_8 bbase_yn; ! if (rystride == ycount) ! memset (dest, 0, (sizeof (GFC_COMPLEX_8) * size0((array_t *) retarray))); ! else ! { ! for (y = 0; y < ycount; y++) ! for (x = 0; x < xcount; x++) ! dest[x + y*rystride] = (GFC_COMPLEX_8)0; ! } for (y = 0; y < ycount; y++) { diff -Nrcpad gcc-4.0.1/libgfortran/generated/matmul_i4.c gcc-4.0.2/libgfortran/generated/matmul_i4.c *** gcc-4.0.1/libgfortran/generated/matmul_i4.c Wed Jan 12 21:27:32 2005 --- gcc-4.0.2/libgfortran/generated/matmul_i4.c Fri Jul 15 20:47:34 2005 *************** matmul_i4 (gfc_array_i4 * retarray, gfc_ *** 167,176 **** ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } - assert (a->base == 0); - assert (b->base == 0); - assert (retarray->base == 0); - abase = a->data; bbase = b->data; dest = retarray->data; --- 167,172 ---- *************** matmul_i4 (gfc_array_i4 * retarray, gfc_ *** 182,188 **** GFC_INTEGER_4 *abase_n; GFC_INTEGER_4 bbase_yn; ! memset (dest, 0, (sizeof (GFC_INTEGER_4) * size0(retarray))); for (y = 0; y < ycount; y++) { --- 178,191 ---- GFC_INTEGER_4 *abase_n; GFC_INTEGER_4 bbase_yn; ! if (rystride == ycount) ! memset (dest, 0, (sizeof (GFC_INTEGER_4) * size0((array_t *) retarray))); ! else ! { ! for (y = 0; y < ycount; y++) ! for (x = 0; x < xcount; x++) ! dest[x + y*rystride] = (GFC_INTEGER_4)0; ! } for (y = 0; y < ycount; y++) { diff -Nrcpad gcc-4.0.1/libgfortran/generated/matmul_i8.c gcc-4.0.2/libgfortran/generated/matmul_i8.c *** gcc-4.0.1/libgfortran/generated/matmul_i8.c Wed Jan 12 21:27:32 2005 --- gcc-4.0.2/libgfortran/generated/matmul_i8.c Fri Jul 15 20:47:34 2005 *************** matmul_i8 (gfc_array_i8 * retarray, gfc_ *** 167,176 **** ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } - assert (a->base == 0); - assert (b->base == 0); - assert (retarray->base == 0); - abase = a->data; bbase = b->data; dest = retarray->data; --- 167,172 ---- *************** matmul_i8 (gfc_array_i8 * retarray, gfc_ *** 182,188 **** GFC_INTEGER_8 *abase_n; GFC_INTEGER_8 bbase_yn; ! memset (dest, 0, (sizeof (GFC_INTEGER_8) * size0(retarray))); for (y = 0; y < ycount; y++) { --- 178,191 ---- GFC_INTEGER_8 *abase_n; GFC_INTEGER_8 bbase_yn; ! if (rystride == ycount) ! memset (dest, 0, (sizeof (GFC_INTEGER_8) * size0((array_t *) retarray))); ! else ! { ! for (y = 0; y < ycount; y++) ! for (x = 0; x < xcount; x++) ! dest[x + y*rystride] = (GFC_INTEGER_8)0; ! } for (y = 0; y < ycount; y++) { diff -Nrcpad gcc-4.0.1/libgfortran/generated/matmul_r4.c gcc-4.0.2/libgfortran/generated/matmul_r4.c *** gcc-4.0.1/libgfortran/generated/matmul_r4.c Wed Jan 12 21:27:32 2005 --- gcc-4.0.2/libgfortran/generated/matmul_r4.c Fri Jul 15 20:47:34 2005 *************** matmul_r4 (gfc_array_r4 * retarray, gfc_ *** 167,176 **** ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } - assert (a->base == 0); - assert (b->base == 0); - assert (retarray->base == 0); - abase = a->data; bbase = b->data; dest = retarray->data; --- 167,172 ---- *************** matmul_r4 (gfc_array_r4 * retarray, gfc_ *** 182,188 **** GFC_REAL_4 *abase_n; GFC_REAL_4 bbase_yn; ! memset (dest, 0, (sizeof (GFC_REAL_4) * size0(retarray))); for (y = 0; y < ycount; y++) { --- 178,191 ---- GFC_REAL_4 *abase_n; GFC_REAL_4 bbase_yn; ! if (rystride == ycount) ! memset (dest, 0, (sizeof (GFC_REAL_4) * size0((array_t *) retarray))); ! else ! { ! for (y = 0; y < ycount; y++) ! for (x = 0; x < xcount; x++) ! dest[x + y*rystride] = (GFC_REAL_4)0; ! } for (y = 0; y < ycount; y++) { diff -Nrcpad gcc-4.0.1/libgfortran/generated/matmul_r8.c gcc-4.0.2/libgfortran/generated/matmul_r8.c *** gcc-4.0.1/libgfortran/generated/matmul_r8.c Wed Jan 12 21:27:32 2005 --- gcc-4.0.2/libgfortran/generated/matmul_r8.c Fri Jul 15 20:47:34 2005 *************** matmul_r8 (gfc_array_r8 * retarray, gfc_ *** 167,176 **** ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } - assert (a->base == 0); - assert (b->base == 0); - assert (retarray->base == 0); - abase = a->data; bbase = b->data; dest = retarray->data; --- 167,172 ---- *************** matmul_r8 (gfc_array_r8 * retarray, gfc_ *** 182,188 **** GFC_REAL_8 *abase_n; GFC_REAL_8 bbase_yn; ! memset (dest, 0, (sizeof (GFC_REAL_8) * size0(retarray))); for (y = 0; y < ycount; y++) { --- 178,191 ---- GFC_REAL_8 *abase_n; GFC_REAL_8 bbase_yn; ! if (rystride == ycount) ! memset (dest, 0, (sizeof (GFC_REAL_8) * size0((array_t *) retarray))); ! else ! { ! for (y = 0; y < ycount; y++) ! for (x = 0; x < xcount; x++) ! dest[x + y*rystride] = (GFC_REAL_8)0; ! } for (y = 0; y < ycount; y++) { diff -Nrcpad gcc-4.0.1/libgfortran/generated/reshape_c4.c gcc-4.0.2/libgfortran/generated/reshape_c4.c *** gcc-4.0.1/libgfortran/generated/reshape_c4.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/reshape_c4.c Sun Jul 17 19:12:00 2005 *************** reshape_c4 (gfc_array_c4 * ret, gfc_arra *** 174,182 **** if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= 4; ! ssize *= 4; ! psize *= 4; reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; --- 174,182 ---- if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= sizeof (GFC_COMPLEX_4); ! ssize *= sizeof (GFC_COMPLEX_4); ! psize *= sizeof (GFC_COMPLEX_4); reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; diff -Nrcpad gcc-4.0.1/libgfortran/generated/reshape_c8.c gcc-4.0.2/libgfortran/generated/reshape_c8.c *** gcc-4.0.1/libgfortran/generated/reshape_c8.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/reshape_c8.c Sun Jul 17 19:12:00 2005 *************** reshape_c8 (gfc_array_c8 * ret, gfc_arra *** 174,182 **** if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= 8; ! ssize *= 8; ! psize *= 8; reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; --- 174,182 ---- if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= sizeof (GFC_COMPLEX_8); ! ssize *= sizeof (GFC_COMPLEX_8); ! psize *= sizeof (GFC_COMPLEX_8); reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; diff -Nrcpad gcc-4.0.1/libgfortran/generated/reshape_i4.c gcc-4.0.2/libgfortran/generated/reshape_i4.c *** gcc-4.0.1/libgfortran/generated/reshape_i4.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/reshape_i4.c Sun Jul 17 19:12:00 2005 *************** reshape_4 (gfc_array_i4 * ret, gfc_array *** 174,182 **** if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= 4; ! ssize *= 4; ! psize *= 4; reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; --- 174,182 ---- if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= sizeof (GFC_INTEGER_4); ! ssize *= sizeof (GFC_INTEGER_4); ! psize *= sizeof (GFC_INTEGER_4); reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; diff -Nrcpad gcc-4.0.1/libgfortran/generated/reshape_i8.c gcc-4.0.2/libgfortran/generated/reshape_i8.c *** gcc-4.0.1/libgfortran/generated/reshape_i8.c Mon May 23 20:03:52 2005 --- gcc-4.0.2/libgfortran/generated/reshape_i8.c Sun Jul 17 19:12:00 2005 *************** reshape_8 (gfc_array_i8 * ret, gfc_array *** 174,182 **** if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= 8; ! ssize *= 8; ! psize *= 8; reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; --- 174,182 ---- if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= sizeof (GFC_INTEGER_8); ! ssize *= sizeof (GFC_INTEGER_8); ! psize *= sizeof (GFC_INTEGER_8); reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; diff -Nrcpad gcc-4.0.1/libgfortran/intrinsics/eoshift0.c gcc-4.0.2/libgfortran/intrinsics/eoshift0.c *** gcc-4.0.1/libgfortran/intrinsics/eoshift0.c Mon May 23 20:03:50 2005 --- gcc-4.0.2/libgfortran/intrinsics/eoshift0.c Thu Jul 14 21:17:22 2005 *************** eoshift0 (gfc_array_char * ret, const gf *** 125,134 **** sstride0 = sstride[0]; rptr = ret->data; sptr = array->data; ! if (shift > 0) ! len = len - shift; else ! len = len + shift; while (rptr) { --- 125,143 ---- sstride0 = sstride[0]; rptr = ret->data; sptr = array->data; ! ! if ((shift >= 0 ? shift : -shift) > len) ! { ! shift = len; ! len = 0; ! } else ! { ! if (shift > 0) ! len = len - shift; ! else ! len = len + shift; ! } while (rptr) { diff -Nrcpad gcc-4.0.1/libgfortran/intrinsics/eoshift2.c gcc-4.0.2/libgfortran/intrinsics/eoshift2.c *** gcc-4.0.1/libgfortran/intrinsics/eoshift2.c Mon May 23 20:03:50 2005 --- gcc-4.0.2/libgfortran/intrinsics/eoshift2.c Thu Jul 14 21:17:22 2005 *************** eoshift2 (gfc_array_char *ret, const gfc *** 133,148 **** bstride0 = bstride[0]; rptr = ret->data; sptr = array->data; if (bound) bptr = bound->data; else bptr = zeros; - if (shift > 0) - len = len - shift; - else - len = len + shift; - while (rptr) { /* Do the shift for this dimension. */ --- 133,157 ---- bstride0 = bstride[0]; rptr = ret->data; sptr = array->data; + + if ((shift >= 0 ? shift : -shift ) > len) + { + shift = len; + len = 0; + } + else + { + if (shift > 0) + len = len - shift; + else + len = len + shift; + } + if (bound) bptr = bound->data; else bptr = zeros; while (rptr) { /* Do the shift for this dimension. */ diff -Nrcpad gcc-4.0.1/libgfortran/intrinsics/etime.c gcc-4.0.2/libgfortran/intrinsics/etime.c *** gcc-4.0.1/libgfortran/intrinsics/etime.c Wed Jan 12 21:27:30 2005 --- gcc-4.0.2/libgfortran/intrinsics/etime.c Tue Jul 12 01:50:36 2005 *************** void *** 46,52 **** etime_sub (gfc_array_r4 *t, GFC_REAL_4 *result) { GFC_REAL_4 tu, ts, tt, *tp; - index_type dim; #if defined(HAVE_SYS_TIME_H) && defined(HAVE_SYS_RESOURCE_H) struct rusage rt; --- 46,51 ---- diff -Nrcpad gcc-4.0.1/libgfortran/intrinsics/flush.c gcc-4.0.2/libgfortran/intrinsics/flush.c *** gcc-4.0.1/libgfortran/intrinsics/flush.c Wed Jan 12 21:27:30 2005 --- gcc-4.0.2/libgfortran/intrinsics/flush.c Mon Aug 1 21:15:22 2005 *************** *** 1,5 **** /* Implementation of the FLUSH intrinsic. ! Copyright (C) 2004 Free Software Foundation, Inc. Contributed by Steven G. Kargl . This file is part of the GNU Fortran 95 runtime library (libgfortran). --- 1,5 ---- /* Implementation of the FLUSH intrinsic. ! Copyright (C) 2004, 2005 Free Software Foundation, Inc. Contributed by Steven G. Kargl . This file is part of the GNU Fortran 95 runtime library (libgfortran). *************** flush_i4 (GFC_INTEGER_4 *unit) *** 75,77 **** --- 75,100 ---- flush (us->s); } } + + + extern void flush_i8 (GFC_INTEGER_8 *); + export_proto(flush_i8); + + void + flush_i8 (GFC_INTEGER_8 *unit) + { + gfc_unit *us; + + /* flush all streams */ + if (unit == NULL) + { + us = g.unit_root; + recursive_flush(us); + } + else + { + us = find_unit(*unit); + if (us != NULL) + flush (us->s); + } + } diff -Nrcpad gcc-4.0.1/libgfortran/intrinsics/getcwd.c gcc-4.0.2/libgfortran/intrinsics/getcwd.c *** gcc-4.0.1/libgfortran/intrinsics/getcwd.c Wed Jan 12 21:27:30 2005 --- gcc-4.0.2/libgfortran/intrinsics/getcwd.c Tue Jul 12 01:50:36 2005 *************** iexport_proto(getcwd_i4_sub); *** 46,52 **** void getcwd_i4_sub (char *cwd, GFC_INTEGER_4 *status, gfc_charlen_type cwd_len) { ! char str[cwd_len + 1], *s; GFC_INTEGER_4 stat; memset(cwd, ' ', (size_t) cwd_len); --- 46,52 ---- void getcwd_i4_sub (char *cwd, GFC_INTEGER_4 *status, gfc_charlen_type cwd_len) { ! char str[cwd_len + 1]; GFC_INTEGER_4 stat; memset(cwd, ' ', (size_t) cwd_len); diff -Nrcpad gcc-4.0.1/libgfortran/intrinsics/stat.c gcc-4.0.2/libgfortran/intrinsics/stat.c *** gcc-4.0.1/libgfortran/intrinsics/stat.c Mon May 23 20:03:51 2005 --- gcc-4.0.2/libgfortran/intrinsics/stat.c Tue Jul 12 01:50:36 2005 *************** stat_i4_sub (char *name, gfc_array_i4 *s *** 73,80 **** char *str; struct stat sb; - index_type stride[GFC_MAX_DIMENSIONS]; - /* If the rank of the array is not 1, abort. */ if (GFC_DESCRIPTOR_RANK (sarray) != 1) runtime_error ("Array rank of SARRAY is not 1."); --- 73,78 ---- *************** stat_i8_sub (char *name, gfc_array_i8 *s *** 168,175 **** char *str; struct stat sb; - index_type stride[GFC_MAX_DIMENSIONS]; - /* If the rank of the array is not 1, abort. */ if (GFC_DESCRIPTOR_RANK (sarray) != 1) runtime_error ("Array rank of SARRAY is not 1."); --- 166,171 ---- *************** fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_a *** 293,300 **** int val; struct stat sb; - index_type stride[GFC_MAX_DIMENSIONS]; - /* If the rank of the array is not 1, abort. */ if (GFC_DESCRIPTOR_RANK (sarray) != 1) runtime_error ("Array rank of SARRAY is not 1."); --- 289,294 ---- *************** fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_a *** 378,385 **** { int val; struct stat sb; - - index_type stride[GFC_MAX_DIMENSIONS]; /* If the rank of the array is not 1, abort. */ if (GFC_DESCRIPTOR_RANK (sarray) != 1) --- 372,377 ---- diff -Nrcpad gcc-4.0.1/libgfortran/intrinsics/tty.c gcc-4.0.2/libgfortran/intrinsics/tty.c *** gcc-4.0.1/libgfortran/intrinsics/tty.c Thu Jan 1 00:00:00 1970 --- gcc-4.0.2/libgfortran/intrinsics/tty.c Tue Aug 9 17:44:56 2005 *************** *** 0 **** --- 1,97 ---- + /* Implementation of the ISATTY and TTYNAM g77 intrinsics. + Copyright (C) 2005 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert + + This file is part of the GNU Fortran 95 runtime library (libgfortran). + + Libgfortran is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + In addition to the permissions in the GNU General Public License, the + Free Software Foundation gives you unlimited permission to link the + compiled version of this file into combinations with other programs, + and to distribute those combinations without any restriction coming + from the use of this file. (The General Public License restrictions + do apply in other respects; for example, they cover modification of + the file, and distribution when not linked into a combine + executable.) + + Libgfortran is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with libgfortran; see the file COPYING. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + + #include "config.h" + #include "libgfortran.h" + #include "../io/io.h" + #include + + /* LOGICAL FUNCTION ISATTY(UNIT) + INTEGER, INTENT(IN) :: UNIT */ + + extern GFC_LOGICAL_4 isatty_l4 (int *); + export_proto(isatty_l4); + + GFC_LOGICAL_4 + isatty_l4 (int *unit) + { + gfc_unit *u; + + u = find_unit (*unit); + if (u != NULL) + return (GFC_LOGICAL_4) stream_isatty (u->s); + else + return 0; + } + + + extern GFC_LOGICAL_8 isatty_l8 (int *); + export_proto(isatty_l8); + + GFC_LOGICAL_8 + isatty_l8 (int *unit) + { + gfc_unit *u; + + u = find_unit (*unit); + if (u != NULL) + return (GFC_LOGICAL_8) stream_isatty (u->s); + else + return 0; + } + + + /* SUBROUTINE TTYNAM(UNIT,NAME) + INTEGER,SCALAR,INTENT(IN) :: UNIT + CHARACTER,SCALAR,INTENT(OUT) :: NAME */ + + extern void ttynam_sub (int *, char *, gfc_charlen_type); + export_proto(ttynam_sub); + + void + ttynam_sub (int *unit, char * name, gfc_charlen_type name_len) + { + gfc_unit *u; + char * n; + int i; + + memset (name, ' ', name_len); + u = find_unit (*unit); + if (u != NULL) + { + n = stream_ttyname (u->s); + if (n != NULL) + { + i = 0; + while (*n && i < name_len) + name[i++] = *(n++); + } + } + } diff -Nrcpad gcc-4.0.1/libgfortran/intrinsics/unlink.c gcc-4.0.2/libgfortran/intrinsics/unlink.c *** gcc-4.0.1/libgfortran/intrinsics/unlink.c Wed Jan 12 21:27:30 2005 --- gcc-4.0.2/libgfortran/intrinsics/unlink.c Tue Jul 12 01:50:36 2005 *************** iexport_proto(unlink_i4_sub); *** 51,57 **** void unlink_i4_sub (char *name, GFC_INTEGER_4 *status, gfc_charlen_type name_len) { ! char *str, *s; GFC_INTEGER_4 stat; /* Trim trailing spaces from name. */ --- 51,57 ---- void unlink_i4_sub (char *name, GFC_INTEGER_4 *status, gfc_charlen_type name_len) { ! char *str; GFC_INTEGER_4 stat; /* Trim trailing spaces from name. */ diff -Nrcpad gcc-4.0.1/libgfortran/io/close.c gcc-4.0.2/libgfortran/io/close.c *** gcc-4.0.1/libgfortran/io/close.c Wed Jan 12 21:27:30 2005 --- gcc-4.0.2/libgfortran/io/close.c Fri Sep 9 21:52:12 2005 *************** Boston, MA 02111-1307, USA. */ *** 30,35 **** --- 30,36 ---- #include "config.h" #include "libgfortran.h" #include "io.h" + #include typedef enum { CLOSE_DELETE, CLOSE_KEEP, CLOSE_UNSPECIFIED } *************** st_close (void) *** 50,55 **** --- 51,61 ---- { close_status status; gfc_unit *u; + #if !HAVE_UNLINK_OPEN_FILE + char * path; + + path = NULL; + #endif library_start (); *************** st_close (void) *** 58,64 **** --- 64,73 ---- "Bad STATUS parameter in CLOSE statement"); if (ioparm.library_return != LIBRARY_OK) + { + library_end (); return; + } u = find_unit (ioparm.unit); if (u != NULL) *************** st_close (void) *** 68,81 **** if (status == CLOSE_KEEP) generate_error (ERROR_BAD_OPTION, "Can't KEEP a scratch file on CLOSE"); } else { if (status == CLOSE_DELETE) ! delete_file (u); } close_unit (u); } library_end (); --- 77,106 ---- if (status == CLOSE_KEEP) generate_error (ERROR_BAD_OPTION, "Can't KEEP a scratch file on CLOSE"); + #if !HAVE_UNLINK_OPEN_FILE + path = (char *) gfc_alloca (u->file_len + 1); + unpack_filename (path, u->file, u->file_len); + #endif } else { if (status == CLOSE_DELETE) ! { ! #if HAVE_UNLINK_OPEN_FILE ! delete_file (u); ! #else ! path = (char *) gfc_alloca (u->file_len + 1); ! unpack_filename (path, u->file, u->file_len); ! #endif ! } } close_unit (u); + + #if !HAVE_UNLINK_OPEN_FILE + if (path != NULL) + unlink (path); + #endif } library_end (); diff -Nrcpad gcc-4.0.1/libgfortran/io/format.c gcc-4.0.2/libgfortran/io/format.c *** gcc-4.0.1/libgfortran/io/format.c Sun May 29 12:22:54 2005 --- gcc-4.0.2/libgfortran/io/format.c Thu Aug 11 13:53:22 2005 *************** parse_format_list (void) *** 452,457 **** --- 452,458 ---- /* Get the next format item */ format_item: t = format_lex (); + format_item_1: switch (t) { case FMT_POSINT: *************** parse_format_list (void) *** 576,581 **** --- 577,583 ---- case FMT_DOLLAR: get_fnode (&head, &tail, FMT_DOLLAR); tail->repeat = 1; + notify_std (GFC_STD_GNU, "Extension: $ descriptor"); goto between_desc; case FMT_T: *************** parse_format_list (void) *** 854,861 **** goto finished; default: ! error = "Missing comma in format"; ! goto finished; } /* Optional comma is a weird between state where we've just finished --- 856,863 ---- goto finished; default: ! /* Assume a missing comma, this is a GNU extension */ ! goto format_item_1; } /* Optional comma is a weird between state where we've just finished diff -Nrcpad gcc-4.0.1/libgfortran/io/io.h gcc-4.0.2/libgfortran/io/io.h *** gcc-4.0.1/libgfortran/io/io.h Sun Jun 5 23:33:52 2005 --- gcc-4.0.2/libgfortran/io/io.h Sun Sep 11 18:55:16 2005 *************** Boston, MA 02111-1307, USA. */ *** 33,39 **** #include #include "libgfortran.h" ! #define DEFAULT_TEMPDIR "/var/tmp" /* Basic types used in data transfers. */ --- 33,39 ---- #include #include "libgfortran.h" ! #define DEFAULT_TEMPDIR "/tmp" /* Basic types used in data transfers. */ *************** internal_proto(file_position); *** 490,504 **** --- 490,516 ---- extern int is_seekable (stream *); internal_proto(is_seekable); + extern int is_preconnected (stream *); + internal_proto(is_preconnected); + extern void empty_internal_buffer(stream *); internal_proto(empty_internal_buffer); extern try flush (stream *); internal_proto(flush); + extern int stream_isatty (stream *); + internal_proto(stream_isatty); + + extern char * stream_ttyname (stream *); + internal_proto(stream_ttyname); + extern int unit_to_fd (int); internal_proto(unit_to_fd); + extern int unpack_filename (char *, const char *, int); + internal_proto(unpack_filename); + /* unit.c */ extern void insert_unit (gfc_unit *); *************** internal_proto(read_f); *** 580,586 **** extern void read_l (fnode *, char *, int); internal_proto(read_l); ! extern void read_x (fnode *); internal_proto(read_x); extern void read_radix (fnode *, char *, int, int); --- 592,598 ---- extern void read_l (fnode *, char *, int); internal_proto(read_l); ! extern void read_x (int); internal_proto(read_x); extern void read_radix (fnode *, char *, int, int); *************** internal_proto(write_l); *** 638,644 **** extern void write_o (fnode *, const char *, int); internal_proto(write_o); ! extern void write_x (fnode *); internal_proto(write_x); extern void write_z (fnode *, const char *, int); --- 650,656 ---- extern void write_o (fnode *, const char *, int); internal_proto(write_o); ! extern void write_x (int, int); internal_proto(write_x); extern void write_z (fnode *, const char *, int); diff -Nrcpad gcc-4.0.1/libgfortran/io/list_read.c gcc-4.0.2/libgfortran/io/list_read.c *** gcc-4.0.1/libgfortran/io/list_read.c Thu Jun 16 23:00:39 2005 --- gcc-4.0.2/libgfortran/io/list_read.c Mon Sep 5 21:14:36 2005 *************** static int nml_read_error; *** 71,77 **** /* Storage area for values except for strings. Must be large enough to hold a complex value (two reals) of the largest kind. */ ! static char value[20]; #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \ case '5': case '6': case '7': case '8': case '9' --- 71,77 ---- /* Storage area for values except for strings. Must be large enough to hold a complex value (two reals) of the largest kind. */ ! static char value[32]; #define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \ case '5': case '6': case '7': case '8': case '9' *************** read_complex (int length) *** 984,994 **** --- 984,1008 ---- if (parse_real (value, length)) return; + eol_1: eat_spaces (); + c = next_char (); + if (c == '\n' || c== '\r') + goto eol_1; + else + unget_char (c); + if (next_char () != ',') goto bad_complex; + eol_2: eat_spaces (); + c = next_char (); + if (c == '\n' || c== '\r') + goto eol_2; + else + unget_char (c); + if (parse_real (value + length, length)) return; *************** nml_get_obj_data (void) *** 2022,2029 **** char c; char * ext_name; namelist_info * nl; ! namelist_info * first_nl; ! namelist_info * root_nl; int dim; int component_flag; --- 2036,2043 ---- char c; char * ext_name; namelist_info * nl; ! namelist_info * first_nl = NULL; ! namelist_info * root_nl = NULL; int dim; int component_flag; *************** get_name: *** 2184,2191 **** if (c == '(' && nl->type == GFC_DTYPE_CHARACTER) { ! descriptor_dimension chd[1] = {1, clow, nl->string_length}; ! nml_loop_spec ind[1] = {1, clow, nl->string_length, 1}; if (nml_parse_qualifier (chd, ind, 1) == FAILURE) { --- 2198,2205 ---- if (c == '(' && nl->type == GFC_DTYPE_CHARACTER) { ! descriptor_dimension chd[1] = { {1, clow, nl->string_length} }; ! nml_loop_spec ind[1] = { {1, clow, nl->string_length, 1} }; if (nml_parse_qualifier (chd, ind, 1) == FAILURE) { diff -Nrcpad gcc-4.0.1/libgfortran/io/lock.c gcc-4.0.2/libgfortran/io/lock.c *** gcc-4.0.1/libgfortran/io/lock.c Sun Jun 5 23:33:52 2005 --- gcc-4.0.2/libgfortran/io/lock.c Mon Aug 29 20:48:35 2005 *************** library_start (void) *** 54,60 **** stay within the library. */ g.in_library = 1; ! if (ioparm.iostat != NULL && ioparm.library_return == LIBRARY_OK) *ioparm.iostat = ERROR_OK; ioparm.library_return = LIBRARY_OK; --- 54,60 ---- stay within the library. */ g.in_library = 1; ! if (ioparm.iostat != NULL) *ioparm.iostat = ERROR_OK; ioparm.library_return = LIBRARY_OK; diff -Nrcpad gcc-4.0.1/libgfortran/io/read.c gcc-4.0.2/libgfortran/io/read.c *** gcc-4.0.1/libgfortran/io/read.c Fri Jun 17 16:23:40 2005 --- gcc-4.0.2/libgfortran/io/read.c Sat Sep 3 19:11:57 2005 *************** set_integer (void *dest, int64_t value, *** 48,63 **** switch (length) { case 8: ! *((int64_t *) dest) = value; break; case 4: ! *((int32_t *) dest) = value; break; case 2: ! *((int16_t *) dest) = value; break; case 1: ! *((int8_t *) dest) = value; break; default: internal_error ("Bad integer kind"); --- 48,75 ---- switch (length) { case 8: ! { ! int64_t tmp = value; ! memcpy (dest, (void *) &tmp, length); ! } break; case 4: ! { ! int32_t tmp = value; ! memcpy (dest, (void *) &tmp, length); ! } break; case 2: ! { ! int16_t tmp = value; ! memcpy (dest, (void *) &tmp, length); ! } break; case 1: ! { ! int8_t tmp = value; ! memcpy (dest, (void *) &tmp, length); ! } break; default: internal_error ("Bad integer kind"); *************** convert_real (void *dest, const char *bu *** 108,122 **** switch (length) { case 4: ! *((float *) dest) = #if defined(HAVE_STRTOF) ! strtof (buffer, NULL); #else ! (float) strtod (buffer, NULL); #endif break; case 8: ! *((double *) dest) = strtod (buffer, NULL); break; default: internal_error ("Unsupported real kind during IO"); --- 120,140 ---- switch (length) { case 4: ! { ! float tmp = #if defined(HAVE_STRTOF) ! strtof (buffer, NULL); #else ! (float) strtod (buffer, NULL); #endif + memcpy (dest, (void *) &tmp, length); + } break; case 8: ! { ! double tmp = strtod (buffer, NULL); ! memcpy (dest, (void *) &tmp, length); ! } break; default: internal_error ("Unsupported real kind during IO"); *************** next_char (char **p, int *w) *** 240,247 **** if (c != ' ') return c; ! if (g.blank_status == BLANK_ZERO) ! return '0'; /* At this point, the rest of the field has to be trailing blanks */ --- 258,265 ---- if (c != ' ') return c; ! if (g.blank_status != BLANK_UNSPECIFIED) ! return ' '; /* return a blank to signal a null */ /* At this point, the rest of the field has to be trailing blanks */ *************** read_decimal (fnode * f, char *dest, int *** 309,315 **** c = next_char (&p, &w); if (c == '\0') break; ! if (c < '0' || c > '9') goto bad; --- 327,339 ---- c = next_char (&p, &w); if (c == '\0') break; ! ! if (c == ' ') ! { ! if (g.blank_status == BLANK_NULL) continue; ! if (g.blank_status == BLANK_ZERO) c = '0'; ! } ! if (c < '0' || c > '9') goto bad; *************** read_radix (fnode * f, char *dest, int l *** 396,401 **** --- 420,430 ---- c = next_char (&p, &w); if (c == '\0') break; + if (c == ' ') + { + if (g.blank_status == BLANK_NULL) continue; + if (g.blank_status == BLANK_ZERO) c = '0'; + } switch (radix) { *************** read_f (fnode * f, char *dest, int lengt *** 640,660 **** p++; w--; ! while (w > 0 && isdigit (*p)) ! { ! exponent = 10 * exponent + *p - '0'; ! p++; ! w--; ! } ! /* Only allow trailing blanks */ ! while (w > 0) { ! if (*p != ' ') ! goto bad_float; ! p++; ! w--; } exponent = exponent * exponent_sign; --- 669,714 ---- p++; w--; ! if (g.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */ ! { ! while (w > 0 && isdigit (*p)) ! { ! exponent = 10 * exponent + *p - '0'; ! p++; ! w--; ! } ! /* Only allow trailing blanks */ ! while (w > 0) ! { ! if (*p != ' ') ! goto bad_float; ! p++; ! w--; ! } ! } ! else /* BZ or BN status is enabled */ { ! while (w > 0) ! { ! if (*p == ' ') ! { ! if (g.blank_status == BLANK_ZERO) *p = '0'; ! if (g.blank_status == BLANK_NULL) ! { ! p++; ! w--; ! continue; ! } ! } ! else if (!isdigit (*p)) ! goto bad_float; ! ! exponent = 10 * exponent + *p - '0'; ! p++; ! w--; ! } } exponent = exponent * exponent_sign; *************** read_f (fnode * f, char *dest, int lengt *** 692,707 **** buffer = get_mem (i); /* Reformat the string into a temporary buffer. As we're using atof it's ! easiest to just leave the dcimal point in place. */ p = buffer; if (val_sign < 0) *(p++) = '-'; for (; ndigits > 0; ndigits--) { ! if (*digits == ' ' && g.blank_status == BLANK_ZERO) ! *p = '0'; ! else ! *p = *digits; p++; digits++; } --- 746,767 ---- buffer = get_mem (i); /* Reformat the string into a temporary buffer. As we're using atof it's ! easiest to just leave the decimal point in place. */ p = buffer; if (val_sign < 0) *(p++) = '-'; for (; ndigits > 0; ndigits--) { ! if (*digits == ' ') ! { ! if (g.blank_status == BLANK_ZERO) *digits = '0'; ! if (g.blank_status == BLANK_NULL) ! { ! digits++; ! continue; ! } ! } ! *p = *digits; p++; digits++; } *************** read_f (fnode * f, char *dest, int lengt *** 722,731 **** * and never look at it. */ void ! read_x (fnode * f) { ! int n; ! n = f->u.n; ! read_block (&n); } --- 782,793 ---- * and never look at it. */ void ! read_x (int n) { ! if ((current_unit->flags.pad == PAD_NO || is_internal_unit ()) ! && current_unit->bytes_left < n) ! n = current_unit->bytes_left; ! if (n > 0) ! read_block (&n); } diff -Nrcpad gcc-4.0.1/libgfortran/io/transfer.c gcc-4.0.2/libgfortran/io/transfer.c *** gcc-4.0.1/libgfortran/io/transfer.c Thu Jun 16 22:32:12 2005 --- gcc-4.0.2/libgfortran/io/transfer.c Sun Sep 11 18:55:16 2005 *************** gfc_unit *current_unit = NULL; *** 82,87 **** --- 82,94 ---- static int sf_seen_eor = 0; static int eor_condition = 0; + /* Maximum righthand column written to. */ + static int max_pos; + /* Number of skips + spaces to be done for T and X-editing. */ + static int skips; + /* Number of spaces to be done for T and X-editing. */ + static int pending_spaces; + char scratch[SCRATCH_SIZE] = { }; static char *line_buffer = NULL; *************** read_sf (int *length) *** 166,176 **** do { if (is_internal_unit()) ! { /* readlen may be modified inside salloc_r if is_internal_unit() is true. */ ! readlen = 1; ! } q = salloc_r (current_unit->s, &readlen); if (q == NULL) --- 173,183 ---- do { if (is_internal_unit()) ! { /* readlen may be modified inside salloc_r if is_internal_unit() is true. */ ! readlen = 1; ! } q = salloc_r (current_unit->s, &readlen); if (q == NULL) *************** read_sf (int *length) *** 204,210 **** current_unit->bytes_left = 0; *length = n; ! sf_seen_eor = 1; break; } --- 211,217 ---- current_unit->bytes_left = 0; *length = n; ! sf_seen_eor = 1; break; } *************** require_type (bt expected, bt actual, fn *** 437,445 **** static void formatted_transfer (bt type, void *p, int len) { ! int pos ,m ; fnode *f; ! int i, n; int consume_data_flag; /* Change a complex data item into a pair of reals. */ --- 444,453 ---- static void formatted_transfer (bt type, void *p, int len) { ! int pos, bytes_used; fnode *f; ! format_token t; ! int n; int consume_data_flag; /* Change a complex data item into a pair of reals. */ *************** formatted_transfer (bt type, void *p, in *** 456,467 **** for (;;) { /* If reversion has occurred and there is another real data item, ! then we have to move to the next record. */ if (g.reversion_flag && n > 0) ! { ! g.reversion_flag = 0; ! next_record (0); ! } consume_data_flag = 1 ; if (ioparm.library_return != LIBRARY_OK) --- 464,475 ---- for (;;) { /* If reversion has occurred and there is another real data item, ! then we have to move to the next record. */ if (g.reversion_flag && n > 0) ! { ! g.reversion_flag = 0; ! next_record (0); ! } consume_data_flag = 1 ; if (ioparm.library_return != LIBRARY_OK) *************** formatted_transfer (bt type, void *p, in *** 469,477 **** f = next_format (); if (f == NULL) ! return; /* No data descriptors left (already raised). */ ! switch (f->format) { case FMT_I: if (n == 0) --- 477,510 ---- f = next_format (); if (f == NULL) ! return; /* No data descriptors left (already raised). */ ! /* Now discharge T, TR and X movements to the right. This is delayed ! until a data producing format to supress trailing spaces. */ ! t = f->format; ! if (g.mode == WRITING && skips != 0 ! && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O ! || t == FMT_Z || t == FMT_F || t == FMT_E ! || t == FMT_EN || t == FMT_ES || t == FMT_G ! || t == FMT_L || t == FMT_A || t == FMT_D)) ! || t == FMT_STRING)) ! { ! if (skips > 0) ! { ! write_x (skips, pending_spaces); ! max_pos = (int)(current_unit->recl - current_unit->bytes_left); ! } ! if (skips < 0) ! { ! move_pos_offset (current_unit->s, skips); ! current_unit->bytes_left -= (gfc_offset)skips; ! } ! skips = pending_spaces = 0; ! } ! ! bytes_used = (int)(current_unit->recl - current_unit->bytes_left); ! ! switch (t) { case FMT_I: if (n == 0) *************** formatted_transfer (bt type, void *p, in *** 524,531 **** case FMT_A: if (n == 0) goto need_data; - if (require_type (BT_CHARACTER, type, f)) - return; if (g.mode == READING) read_a (f, p, len); --- 557,562 ---- *************** formatted_transfer (bt type, void *p, in *** 653,659 **** break; case FMT_STRING: ! consume_data_flag = 0 ; if (g.mode == READING) { format_error (f, "Constant string in input format"); --- 684,690 ---- break; case FMT_STRING: ! consume_data_flag = 0 ; if (g.mode == READING) { format_error (f, "Constant string in input format"); *************** formatted_transfer (bt type, void *p, in *** 662,754 **** write_constant_string (f); break; ! /* Format codes that don't transfer data. */ case FMT_X: case FMT_TR: ! consume_data_flag = 0 ; if (g.mode == READING) ! read_x (f); ! else ! write_x (f); break; ! case FMT_TL: ! case FMT_T: ! if (f->format == FMT_TL) ! pos = current_unit->recl - current_unit->bytes_left - f->u.n; ! else /* FMT_T */ ! { ! consume_data_flag = 0 ; ! pos = f->u.n - 1; ! } ! if (pos < 0 || pos >= current_unit->recl ) ! { ! generate_error (ERROR_EOR, "T or TL edit position error"); ! break ; ! } ! m = pos - (current_unit->recl - current_unit->bytes_left); ! if (m == 0) ! break; ! if (m > 0) ! { ! f->u.n = m; ! if (g.mode == READING) ! read_x (f); ! else ! write_x (f); ! } ! if (m < 0) ! { ! move_pos_offset (current_unit->s,m); ! current_unit->bytes_left -= m; ! } ! break; case FMT_S: ! consume_data_flag = 0 ; g.sign_status = SIGN_S; ! break; case FMT_SS: ! consume_data_flag = 0 ; g.sign_status = SIGN_SS; ! break; case FMT_SP: ! consume_data_flag = 0 ; g.sign_status = SIGN_SP; ! break; case FMT_BN: ! consume_data_flag = 0 ; g.blank_status = BLANK_NULL; ! break; case FMT_BZ: ! consume_data_flag = 0 ; g.blank_status = BLANK_ZERO; ! break; case FMT_P: ! consume_data_flag = 0 ; g.scale_factor = f->u.k; break; case FMT_DOLLAR: ! consume_data_flag = 0 ; g.seen_dollar = 1; break; case FMT_SLASH: ! consume_data_flag = 0 ; ! for (i = 0; i < f->repeat; i++) ! next_record (0); ! break; case FMT_COLON: --- 693,791 ---- write_constant_string (f); break; ! /* Format codes that don't transfer data. */ case FMT_X: case FMT_TR: ! consume_data_flag = 0 ; ! ! pos = bytes_used + f->u.n + skips; ! skips = f->u.n + skips; ! pending_spaces = pos - max_pos; ! ! /* Writes occur just before the switch on f->format, above, so that ! trailing blanks are suppressed. */ if (g.mode == READING) ! read_x (f->u.n); break; ! case FMT_TL: ! case FMT_T: ! if (f->format == FMT_TL) ! pos = bytes_used - f->u.n; ! else /* FMT_T */ ! { ! consume_data_flag = 0; ! pos = f->u.n - 1; ! } ! /* Standard 10.6.1.1: excessive left tabbing is reset to the ! left tab limit. We do not check if the position has gone ! beyond the end of record because a subsequent tab could ! bring us back again. */ ! pos = pos < 0 ? 0 : pos; ! skips = skips + pos - bytes_used; ! pending_spaces = pending_spaces + pos - max_pos; ! if (skips == 0) ! break; ! /* Writes occur just before the switch on f->format, above, so that ! trailing blanks are suppressed. */ ! if (g.mode == READING) ! { ! if (skips > 0) ! read_x (skips); ! if (skips < 0) ! { ! move_pos_offset (current_unit->s, skips); ! current_unit->bytes_left -= skips; ! skips = pending_spaces = 0; ! } ! } ! ! break; case FMT_S: ! consume_data_flag = 0 ; g.sign_status = SIGN_S; ! break; case FMT_SS: ! consume_data_flag = 0 ; g.sign_status = SIGN_SS; ! break; case FMT_SP: ! consume_data_flag = 0 ; g.sign_status = SIGN_SP; ! break; case FMT_BN: ! consume_data_flag = 0 ; g.blank_status = BLANK_NULL; ! break; case FMT_BZ: ! consume_data_flag = 0 ; g.blank_status = BLANK_ZERO; ! break; case FMT_P: ! consume_data_flag = 0 ; g.scale_factor = f->u.k; break; case FMT_DOLLAR: ! consume_data_flag = 0 ; g.seen_dollar = 1; break; case FMT_SLASH: ! consume_data_flag = 0 ; ! skips = pending_spaces = 0; ! next_record (0); break; case FMT_COLON: *************** formatted_transfer (bt type, void *p, in *** 756,762 **** particular preventing another / descriptor from being processed) unless there is another data item to be transferred. */ ! consume_data_flag = 0 ; if (n == 0) return; break; --- 793,799 ---- particular preventing another / descriptor from being processed) unless there is another data item to be transferred. */ ! consume_data_flag = 0 ; if (n == 0) return; break; *************** formatted_transfer (bt type, void *p, in *** 780,787 **** if ((consume_data_flag > 0) && (n > 0)) { n--; ! p = ((char *) p) + len; } } return; --- 817,831 ---- if ((consume_data_flag > 0) && (n > 0)) { n--; ! p = ((char *) p) + len; } + + if (g.mode == READING) + skips = 0; + + pos = (int)(current_unit->recl - current_unit->bytes_left); + max_pos = (max_pos > pos) ? max_pos : pos; + } return; *************** data_transfer_init (int read_flag) *** 981,987 **** { current_unit->recl = file_length(current_unit->s); if (g.mode==WRITING) ! empty_internal_buffer (current_unit->s); } /* Check the action. */ --- 1025,1033 ---- { current_unit->recl = file_length(current_unit->s); if (g.mode==WRITING) ! empty_internal_buffer (current_unit->s); ! else ! current_unit->bytes_left = current_unit->recl; } /* Check the action. */ *************** data_transfer_init (int read_flag) *** 1011,1024 **** if (ioparm.namelist_name != NULL && ionml != NULL) { ! if(ioparm.format != NULL) ! generate_error (ERROR_OPTION_CONFLICT, ! "A format cannot be specified with a namelist"); } else if (current_unit->flags.form == FORM_FORMATTED && ! ioparm.format == NULL && !ioparm.list_format) generate_error (ERROR_OPTION_CONFLICT, ! "Missing format for FORMATTED data transfer"); if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED) --- 1057,1070 ---- if (ioparm.namelist_name != NULL && ionml != NULL) { ! if(ioparm.format != NULL) ! generate_error (ERROR_OPTION_CONFLICT, ! "A format cannot be specified with a namelist"); } else if (current_unit->flags.form == FORM_FORMATTED && ! ioparm.format == NULL && !ioparm.list_format) generate_error (ERROR_OPTION_CONFLICT, ! "Missing format for FORMATTED data transfer"); if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED) *************** data_transfer_init (int read_flag) *** 1112,1125 **** /* Check to see if we might be reading what we wrote before */ if (g.mode == READING && current_unit->mode == WRITING) ! flush(current_unit->s); /* Position the file. */ if (sseek (current_unit->s, ! (ioparm.rec - 1) * current_unit->recl) == FAILURE) ! generate_error (ERROR_OS, NULL); } current_unit->mode = g.mode; /* Set the initial value of flags. */ --- 1158,1191 ---- /* Check to see if we might be reading what we wrote before */ if (g.mode == READING && current_unit->mode == WRITING) ! flush(current_unit->s); ! ! /* Check whether the record exists to be read. Only ! a partial record needs to exist. */ ! ! if (g.mode == READING && (ioparm.rec -1) ! * current_unit->recl >= file_length (current_unit->s)) ! { ! generate_error (ERROR_BAD_OPTION, "Non-existing record number"); ! return; ! } /* Position the file. */ if (sseek (current_unit->s, ! (ioparm.rec - 1) * current_unit->recl) == FAILURE) ! { ! generate_error (ERROR_OS, NULL); ! return; ! } } + /* Overwriting an existing sequential file ? + it is always safe to truncate the file on the first write */ + if (g.mode == WRITING + && current_unit->flags.access == ACCESS_SEQUENTIAL + && current_unit->last_record == 0 && !is_preconnected(current_unit->s)) + struncate(current_unit->s); + current_unit->mode = g.mode; /* Set the initial value of flags. */ *************** data_transfer_init (int read_flag) *** 1144,1153 **** else { if (ioparm.list_format) ! { ! transfer = list_formatted_read; ! init_at_eol(); ! } else transfer = formatted_transfer; } --- 1210,1219 ---- else { if (ioparm.list_format) ! { ! transfer = list_formatted_read; ! init_at_eol(); ! } else transfer = formatted_transfer; } *************** data_transfer_init (int read_flag) *** 1182,1187 **** --- 1248,1256 ---- current_unit->read_bad = 1; } + /* Reset counters for T and X-editing. */ + max_pos = skips = pending_spaces = 0; + /* Start the data transfer if we are doing a formatted transfer. */ if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format && ioparm.namelist_name == NULL && ionml == NULL) *************** next_record_r (int done) *** 1253,1279 **** } do ! { ! p = salloc_r (current_unit->s, &length); ! /* In case of internal file, there may not be any '\n'. */ ! if (is_internal_unit() && p == NULL) ! { ! break; ! } ! if (p == NULL) ! { ! generate_error (ERROR_OS, NULL); ! break; ! } ! if (length == 0) ! { ! current_unit->endfile = AT_ENDFILE; ! break; ! } ! } while (*p != '\n'); break; --- 1322,1348 ---- } do ! { ! p = salloc_r (current_unit->s, &length); ! /* In case of internal file, there may not be any '\n'. */ ! if (is_internal_unit() && p == NULL) ! { ! break; ! } ! if (p == NULL) ! { ! generate_error (ERROR_OS, NULL); ! break; ! } ! if (length == 0) ! { ! current_unit->endfile = AT_ENDFILE; ! break; ! } ! } while (*p != '\n'); break; *************** next_record_w (int done) *** 1293,1298 **** --- 1362,1370 ---- int length; char *p; + /* Zero counters for X- and T-editing. */ + max_pos = skips = pending_spaces = 0; + switch (current_mode ()) { case FORMATTED_DIRECT: *************** next_record_w (int done) *** 1312,1318 **** case UNFORMATTED_DIRECT: if (sfree (current_unit->s) == FAILURE) ! goto io_error; break; case UNFORMATTED_SEQUENTIAL: --- 1384,1390 ---- case UNFORMATTED_DIRECT: if (sfree (current_unit->s) == FAILURE) ! goto io_error; break; case UNFORMATTED_SEQUENTIAL: *************** next_record_w (int done) *** 1350,1365 **** break; case FORMATTED_SEQUENTIAL: length = 1; p = salloc_w (current_unit->s, &length); if (!is_internal_unit()) ! { ! if (p) ! *p = '\n'; /* No CR for internal writes. */ ! else ! goto io_error; ! } if (sfree (current_unit->s) == FAILURE) goto io_error; --- 1422,1448 ---- break; case FORMATTED_SEQUENTIAL: + #ifdef HAVE_CRLF + length = 2; + #else length = 1; + #endif p = salloc_w (current_unit->s, &length); if (!is_internal_unit()) ! { ! if (p) ! { /* No new line for internal writes. */ ! #ifdef HAVE_CRLF ! p[0] = '\r'; ! p[1] = '\n'; ! #else ! *p = '\n'; ! #endif ! } ! else ! goto io_error; ! } if (sfree (current_unit->s) == FAILURE) goto io_error; *************** finalize_transfer (void) *** 1429,1437 **** if ((ionml != NULL) && (ioparm.namelist_name != NULL)) { if (ioparm.namelist_read_mode) ! namelist_read(); else ! namelist_write(); } transfer = NULL; --- 1512,1520 ---- if ((ionml != NULL) && (ioparm.namelist_name != NULL)) { if (ioparm.namelist_read_mode) ! namelist_read(); else ! namelist_write(); } transfer = NULL; *************** static void *** 1477,1483 **** iolength_transfer (bt type, void *dest, int len) { if (ioparm.iolength != NULL) ! *ioparm.iolength += len; } --- 1560,1571 ---- iolength_transfer (bt type, void *dest, int len) { if (ioparm.iolength != NULL) ! { ! if (type == BT_COMPLEX) ! *ioparm.iolength += 2*len; ! else ! *ioparm.iolength += len; ! } } *************** export_proto(st_read); *** 1532,1537 **** --- 1620,1626 ---- void st_read (void) { + library_start (); data_transfer_init (1); *************** st_read (void) *** 1548,1558 **** break; case AT_ENDFILE: ! if (!is_internal_unit()) ! { ! generate_error (ERROR_END, NULL); ! current_unit->endfile = AFTER_ENDFILE; ! } break; case AFTER_ENDFILE: --- 1637,1647 ---- break; case AT_ENDFILE: ! if (!is_internal_unit()) ! { ! generate_error (ERROR_END, NULL); ! current_unit->endfile = AFTER_ENDFILE; ! } break; case AFTER_ENDFILE: *************** export_proto(st_write); *** 1577,1582 **** --- 1666,1672 ---- void st_write (void) { + library_start (); data_transfer_init (0); } *************** st_write_done (void) *** 1603,1613 **** case NO_ENDFILE: if (current_unit->current_record > current_unit->last_record) ! { ! /* Get rid of whatever is after this record. */ ! if (struncate (current_unit->s) == FAILURE) ! generate_error (ERROR_OS, NULL); ! } current_unit->endfile = AT_ENDFILE; break; --- 1693,1703 ---- case NO_ENDFILE: if (current_unit->current_record > current_unit->last_record) ! { ! /* Get rid of whatever is after this record. */ ! if (struncate (current_unit->s) == FAILURE) ! generate_error (ERROR_OS, NULL); ! } current_unit->endfile = AT_ENDFILE; break; diff -Nrcpad gcc-4.0.1/libgfortran/io/unit.c gcc-4.0.2/libgfortran/io/unit.c *** gcc-4.0.1/libgfortran/io/unit.c Thu May 12 19:10:58 2005 --- gcc-4.0.2/libgfortran/io/unit.c Fri Jul 22 19:11:28 2005 *************** is_internal_unit () *** 288,294 **** void init_units (void) { - gfc_offset m, n; gfc_unit *u; int i; --- 288,293 ---- *************** init_units (void) *** 305,311 **** u->flags.access = ACCESS_SEQUENTIAL; u->flags.form = FORM_FORMATTED; u->flags.status = STATUS_OLD; ! u->flags.blank = BLANK_ZERO; u->flags.position = POSITION_ASIS; u->recl = options.default_recl; --- 304,310 ---- u->flags.access = ACCESS_SEQUENTIAL; u->flags.form = FORM_FORMATTED; u->flags.status = STATUS_OLD; ! u->flags.blank = BLANK_UNSPECIFIED; u->flags.position = POSITION_ASIS; u->recl = options.default_recl; *************** init_units (void) *** 327,333 **** u->flags.access = ACCESS_SEQUENTIAL; u->flags.form = FORM_FORMATTED; u->flags.status = STATUS_OLD; ! u->flags.blank = BLANK_ZERO; u->flags.position = POSITION_ASIS; u->recl = options.default_recl; --- 326,332 ---- u->flags.access = ACCESS_SEQUENTIAL; u->flags.form = FORM_FORMATTED; u->flags.status = STATUS_OLD; ! u->flags.blank = BLANK_UNSPECIFIED; u->flags.position = POSITION_ASIS; u->recl = options.default_recl; *************** init_units (void) *** 349,355 **** u->flags.access = ACCESS_SEQUENTIAL; u->flags.form = FORM_FORMATTED; u->flags.status = STATUS_OLD; ! u->flags.blank = BLANK_ZERO; u->flags.position = POSITION_ASIS; u->recl = options.default_recl; --- 348,354 ---- u->flags.access = ACCESS_SEQUENTIAL; u->flags.form = FORM_FORMATTED; u->flags.status = STATUS_OLD; ! u->flags.blank = BLANK_UNSPECIFIED; u->flags.position = POSITION_ASIS; u->recl = options.default_recl; diff -Nrcpad gcc-4.0.1/libgfortran/io/unix.c gcc-4.0.2/libgfortran/io/unix.c *** gcc-4.0.1/libgfortran/io/unix.c Sat Jun 18 20:10:40 2005 --- gcc-4.0.2/libgfortran/io/unix.c Sun Sep 11 18:55:16 2005 *************** typedef struct *** 137,142 **** --- 137,144 ---- int prot; int ndirty; /* Dirty bytes starting at dirty_offset */ + int special_file; /* =1 if the fd refers to a special file */ + unsigned unbuffered:1, mmaped:1; char small_buffer[BUFFER_SIZE]; *************** fix_fd (int fd) *** 215,220 **** --- 217,233 ---- return fd; } + int + is_preconnected (stream * s) + { + int fd; + + fd = ((unix_stream *) s)->fd; + if (fd == STDIN_FILENO || fd == STDOUT_FILENO || fd == STDERR_FILENO) + return 1; + else + return 0; + } /* write()-- Write a buffer to a descriptor, allowing for short writes */ *************** fd_truncate (unix_stream * s) *** 507,519 **** return FAILURE; /* non-seekable files, like terminals and fifo's fail the lseek. ! the fd is a regular file at this point */ ! #ifdef HAVE_FTRUNCATE ! if (ftruncate (s->fd, s->logical_offset)) #else #ifdef HAVE_CHSIZE ! if (chsize (s->fd, s->logical_offset)) #endif #endif { --- 520,533 ---- return FAILURE; /* non-seekable files, like terminals and fifo's fail the lseek. ! Using ftruncate on a seekable special file (like /dev/null) ! is undefined, so we treat it as if the ftruncate failed. ! */ #ifdef HAVE_FTRUNCATE ! if (s->special_file || ftruncate (s->fd, s->logical_offset)) #else #ifdef HAVE_CHSIZE ! if (s->special_file || chsize (s->fd, s->logical_offset)) #endif #endif { *************** fd_to_stream (int fd, int prot, int avoi *** 912,917 **** --- 926,932 ---- fstat (fd, &statbuf); s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1; + s->special_file = !S_ISREG (statbuf.st_mode); #if HAVE_MMAP if (avoid_mmap) *************** unit_to_fd(int unit) *** 945,951 **** * buffer that is PATH_MAX characters, convert the fortran string to a * C string in the buffer. Returns nonzero if this is not possible. */ ! static int unpack_filename (char *cstring, const char *fstring, int len) { len = fstrlen (fstring, len); --- 960,966 ---- * buffer that is PATH_MAX characters, convert the fortran string to a * C string in the buffer. Returns nonzero if this is not possible. */ ! int unpack_filename (char *cstring, const char *fstring, int len) { len = fstrlen (fstring, len); *************** tempfile (void) *** 977,982 **** --- 992,999 ---- if (tempdir == NULL) tempdir = getenv ("TMP"); if (tempdir == NULL) + tempdir = getenv ("TEMP"); + if (tempdir == NULL) tempdir = DEFAULT_TEMPDIR; template = get_mem (strlen (tempdir) + 20); *************** tempfile (void) *** 991,997 **** if (mktemp (template)) do ! fd = open (template, O_CREAT | O_EXCL, S_IREAD | S_IWRITE); while (!(fd == -1 && errno == EEXIST) && mktemp (template)); else fd = -1; --- 1008,1019 ---- if (mktemp (template)) do ! #ifdef HAVE_CRLF ! fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY, ! S_IREAD | S_IWRITE); ! #else ! fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE); ! #endif while (!(fd == -1 && errno == EEXIST) && mktemp (template)); else fd = -1; *************** regular_file (unit_flags *flags) *** 1076,1081 **** --- 1098,1107 ---- /* rwflag |= O_LARGEFILE; */ + #ifdef HAVE_CRLF + crflag |= O_BINARY; + #endif + mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH; fd = open (path, rwflag | crflag, mode); if (flags->action != ACTION_UNSPECIFIED) *************** open_external (unit_flags *flags) *** 1127,1134 **** --- 1153,1163 ---- fd = tempfile (); if (flags->action == ACTION_UNSPECIFIED) flags->action = ACTION_READWRITE; + + #if HAVE_UNLINK_OPEN_FILE /* We can unlink scratch files now and it will go away when closed. */ unlink (ioparm.file); + #endif } else { *************** flush (stream *s) *** 1527,1532 **** --- 1556,1577 ---- return fd_flush( (unix_stream *) s); } + int + stream_isatty (stream *s) + { + return isatty (((unix_stream *) s)->fd); + } + + char * + stream_ttyname (stream *s) + { + #ifdef HAVE_TTYNAME + return ttyname (((unix_stream *) s)->fd); + #else + return NULL; + #endif + } + /* How files are stored: This is an operating-system specific issue, and therefore belongs here. There are three cases to consider. diff -Nrcpad gcc-4.0.1/libgfortran/io/write.c gcc-4.0.2/libgfortran/io/write.c *** gcc-4.0.1/libgfortran/io/write.c Sun Jun 5 23:33:52 2005 --- gcc-4.0.2/libgfortran/io/write.c Wed Sep 7 20:21:34 2005 *************** extract_int (const void *p, int len) *** 80,95 **** switch (len) { case 1: ! i = *((const int8_t *) p); break; case 2: ! i = *((const int16_t *) p); break; case 4: ! i = *((const int32_t *) p); break; case 8: ! i = *((const int64_t *) p); break; default: internal_error ("bad integer kind"); --- 80,111 ---- switch (len) { case 1: ! { ! int8_t tmp; ! memcpy ((void *) &tmp, p, len); ! i = tmp; ! } break; case 2: ! { ! int16_t tmp; ! memcpy ((void *) &tmp, p, len); ! i = tmp; ! } break; case 4: ! { ! int32_t tmp; ! memcpy ((void *) &tmp, p, len); ! i = tmp; ! } break; case 8: ! { ! int64_t tmp; ! memcpy ((void *) &tmp, p, len); ! i = tmp; ! } break; default: internal_error ("bad integer kind"); *************** extract_real (const void *p, int len) *** 105,114 **** switch (len) { case 4: ! i = *((const float *) p); break; case 8: ! i = *((const double *) p); break; default: internal_error ("bad real kind"); --- 121,138 ---- switch (len) { case 4: ! { ! float tmp; ! memcpy ((void *) &tmp, p, len); ! i = tmp; ! } break; case 8: ! { ! double tmp; ! memcpy ((void *) &tmp, p, len); ! i = tmp; ! } break; default: internal_error ("bad real kind"); *************** write_float (fnode *f, const char *sourc *** 702,707 **** --- 726,736 ---- if (res == 0) { nb = f->u.real.w; + + /* If the field width is zero, the processor must select a width + not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */ + + if (nb == 0) nb = 4; p = write_block (nb); if (nb < 3) { *************** write_float (fnode *f, const char *sourc *** 710,731 **** } memset(p, ' ', nb); ! res = !isnan (n); if (res != 0) { ! if (signbit(n)) ! fin = '-'; else ! fin = '+'; ! if (nb > 7) ! memcpy(p + nb - 8, "Infinity", 8); else memcpy(p + nb - 3, "Inf", 3); ! if (nb < 8 && nb > 3) ! p[nb - 4] = fin; else if (nb > 8) ! p[nb - 9] = fin; } else memcpy(p + nb - 3, "NaN", 3); --- 739,785 ---- } memset(p, ' ', nb); ! res = !isnan (n); if (res != 0) { ! if (signbit(n)) ! { ! ! /* If the sign is negative and the width is 3, there is ! insufficient room to output '-Inf', so output asterisks */ ! ! if (nb == 3) ! { ! memset (p, '*',nb); ! return; ! } ! ! /* The negative sign is mandatory */ ! ! fin = '-'; ! } else ! ! /* The positive sign is optional, but we output it for ! consistency */ ! ! fin = '+'; ! if (nb > 8) ! ! /* We have room, so output 'Infinity' */ ! ! memcpy(p + nb - 8, "Infinity", 8); else + + /* For the case of width equals 8, there is not enough room + for the sign and 'Infinity' so we go with 'Inf' */ + memcpy(p + nb - 3, "Inf", 3); ! if (nb < 9 && nb > 3) ! p[nb - 4] = fin; /* Put the sign in front of Inf */ else if (nb > 8) ! p[nb - 9] = fin; /* Put the sign in front of Infinity */ } else memcpy(p + nb - 3, "NaN", 3); *************** otoa (uint64_t n) *** 941,953 **** return scratch; } ! p = scratch + sizeof (SCRATCH_SIZE) - 1; *p-- = '\0'; while (n != 0) { *p = '0' + (n & 7); ! p -- ; n >>= 3; } --- 995,1007 ---- return scratch; } ! p = scratch + SCRATCH_SIZE - 1; *p-- = '\0'; while (n != 0) { *p = '0' + (n & 7); ! p--; n >>= 3; } *************** btoa (uint64_t n) *** 969,975 **** return scratch; } ! p = scratch + sizeof (SCRATCH_SIZE) - 1; *p-- = '\0'; while (n != 0) --- 1023,1029 ---- return scratch; } ! p = scratch + SCRATCH_SIZE - 1; *p-- = '\0'; while (n != 0) *************** write_es (fnode *f, const char *p, int l *** 1047,1061 **** /* Take care of the X/TR descriptor. */ void ! write_x (fnode * f) { char *p; ! p = write_block (f->u.n); if (p == NULL) return; ! memset (p, ' ', f->u.n); } --- 1101,1116 ---- /* Take care of the X/TR descriptor. */ void ! write_x (int m, int nspaces) { char *p; ! p = write_block (m); if (p == NULL) return; ! if (nspaces > 0) ! memset ((char*)(p + m - nspaces), ' ', nspaces); } diff -Nrcpad gcc-4.0.1/libgfortran/libgfortran.h gcc-4.0.2/libgfortran/libgfortran.h *** gcc-4.0.1/libgfortran/libgfortran.h Sat May 7 19:48:14 2005 --- gcc-4.0.2/libgfortran/libgfortran.h Thu Aug 11 13:53:22 2005 *************** typedef off_t gfc_offset; *** 179,195 **** alternatives, or bail out. */ #if (!defined(isfinite) || defined(__CYGWIN__)) #undef isfinite - static inline int - isfinite (double x) - { #if defined(fpclassify) ! return (fpclassify(x) != FP_NAN && fpclassify(x) != FP_INFINITE); ! #elif defined(HAVE_FINITE) ! return finite (x); #else ! #error "libgfortran needs isfinite, fpclassify, or finite" #endif - } #endif /* !defined(isfinite) */ /* TODO: find the C99 version of these an move into above ifdef. */ --- 179,189 ---- alternatives, or bail out. */ #if (!defined(isfinite) || defined(__CYGWIN__)) #undef isfinite #if defined(fpclassify) ! #define isfinite(x) (fpclassify(x) != FP_NAN && fpclassify(x) != FP_INFINITE) #else ! #define isfinite(x) ((x) - (x) == 0) #endif #endif /* !defined(isfinite) */ /* TODO: find the C99 version of these an move into above ifdef. */ *************** typedef struct *** 314,324 **** } options_t; - extern options_t options; internal_proto(options); /* Structure for statement options. */ typedef struct --- 308,332 ---- } options_t; extern options_t options; internal_proto(options); + /* Compile-time options that will influence the library. */ + + typedef struct + { + int warn_std; + int allow_std; + } + compile_options_t; + + extern compile_options_t compile_options; + internal_proto(compile_options); + + + + /* Structure for statement options. */ typedef struct *************** typedef enum *** 353,358 **** --- 361,378 ---- error_codes; + /* Flags to specify which standard/extension contains a feature. + Keep them in sync with their counterparts in gcc/fortran/gfortran.h. */ + #define GFC_STD_LEGACY (1<<6) /* Backward compatibility. */ + #define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */ + #define GFC_STD_F2003 (1<<4) /* New in F2003. */ + /* Note that no features were obsoleted nor deleted in F2003. */ + #define GFC_STD_F95 (1<<3) /* New in F95. */ + #define GFC_STD_F95_DEL (1<<2) /* Deleted in F95. */ + #define GFC_STD_F95_OBS (1<<1) /* Obsoleted in F95. */ + #define GFC_STD_F77 (1<<0) /* Up to and including F77. */ + + /* The filename and line number don't go inside the globals structure. They are set by the rest of the program and must be linked to. */ *************** internal_proto(reshape_packed); *** 482,488 **** /* Repacking functions. */ ! /* ??? These four aren't currently used by the compiler, though we certainly could do so. */ GFC_INTEGER_4 *internal_pack_4 (gfc_array_i4 *); internal_proto(internal_pack_4); --- 502,508 ---- /* Repacking functions. */ ! /* ??? These eight aren't currently used by the compiler, though we certainly could do so. */ GFC_INTEGER_4 *internal_pack_4 (gfc_array_i4 *); internal_proto(internal_pack_4); *************** internal_proto(internal_pack_4); *** 490,501 **** --- 510,533 ---- GFC_INTEGER_8 *internal_pack_8 (gfc_array_i8 *); internal_proto(internal_pack_8); + GFC_COMPLEX_4 *internal_pack_c4 (gfc_array_c4 *); + internal_proto(internal_pack_c4); + + GFC_COMPLEX_8 *internal_pack_c8 (gfc_array_c8 *); + internal_proto(internal_pack_c8); + extern void internal_unpack_4 (gfc_array_i4 *, const GFC_INTEGER_4 *); internal_proto(internal_unpack_4); extern void internal_unpack_8 (gfc_array_i8 *, const GFC_INTEGER_8 *); internal_proto(internal_unpack_8); + extern void internal_unpack_c4 (gfc_array_c4 *, const GFC_COMPLEX_4 *); + internal_proto(internal_unpack_c4); + + extern void internal_unpack_c8 (gfc_array_c8 *, const GFC_COMPLEX_8 *); + internal_proto(internal_unpack_c8); + /* string_intrinsics.c */ extern GFC_INTEGER_4 compare_string (GFC_INTEGER_4, const char *, diff -Nrcpad gcc-4.0.1/libgfortran/m4/cshift1.m4 gcc-4.0.2/libgfortran/m4/cshift1.m4 *** gcc-4.0.1/libgfortran/m4/cshift1.m4 Mon May 23 20:03:48 2005 --- gcc-4.0.2/libgfortran/m4/cshift1.m4 Thu Jul 14 21:17:22 2005 *************** Boston, MA 02111-1307, USA. */ *** 35,47 **** #include "libgfortran.h"' include(iparm.m4)dnl ! void cshift1_`'atype_kind (const gfc_array_char * ret, const gfc_array_char * array, const atype * h, const atype_name * pwhich); export_proto(cshift1_`'atype_kind); void ! cshift1_`'atype_kind (const gfc_array_char * ret, const gfc_array_char * array, const atype * h, const atype_name * pwhich) { --- 35,47 ---- #include "libgfortran.h"' include(iparm.m4)dnl ! void cshift1_`'atype_kind (gfc_array_char * ret, const gfc_array_char * array, const atype * h, const atype_name * pwhich); export_proto(cshift1_`'atype_kind); void ! cshift1_`'atype_kind (gfc_array_char * ret, const gfc_array_char * array, const atype * h, const atype_name * pwhich) { *************** cshift1_`'atype_kind (const gfc_array_ch *** 81,86 **** --- 81,105 ---- size = GFC_DESCRIPTOR_SIZE (ret); + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->base = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + extent[0] = 1; count[0] = 0; size = GFC_DESCRIPTOR_SIZE (array); diff -Nrcpad gcc-4.0.1/libgfortran/m4/eoshift1.m4 gcc-4.0.2/libgfortran/m4/eoshift1.m4 *** gcc-4.0.1/libgfortran/m4/eoshift1.m4 Mon May 23 20:03:48 2005 --- gcc-4.0.2/libgfortran/m4/eoshift1.m4 Thu Jul 14 21:17:22 2005 *************** include(iparm.m4)dnl *** 38,51 **** static const char zeros[16] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; ! extern void eoshift1_`'atype_kind (const gfc_array_char *, const gfc_array_char *, const atype *, const char *, const atype_name *); export_proto(eoshift1_`'atype_kind); void ! eoshift1_`'atype_kind (const gfc_array_char *ret, const gfc_array_char *array, const atype *h, const char *pbound, const atype_name *pwhich) --- 38,51 ---- static const char zeros[16] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; ! extern void eoshift1_`'atype_kind (gfc_array_char *, const gfc_array_char *, const atype *, const char *, const atype_name *); export_proto(eoshift1_`'atype_kind); void ! eoshift1_`'atype_kind (gfc_array_char *ret, const gfc_array_char *array, const atype *h, const char *pbound, const atype_name *pwhich) *************** eoshift1_`'atype_kind (const gfc_array_c *** 90,95 **** --- 90,115 ---- extent[0] = 1; count[0] = 0; size = GFC_DESCRIPTOR_SIZE (array); + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->base = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + n = 0; for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) { *************** eoshift1_`'atype_kind (const gfc_array_c *** 110,116 **** rstride[n] = ret->dim[dim].stride * size; sstride[n] = array->dim[dim].stride * size; ! hstride[n] = h->dim[n].stride; n++; } } --- 130,136 ---- rstride[n] = ret->dim[dim].stride * size; sstride[n] = array->dim[dim].stride * size; ! hstride[n] = h->dim[n].stride * size; n++; } } *************** eoshift1_`'atype_kind (const gfc_array_c *** 133,139 **** { ` /* Do the shift for this dimension. */' sh = *hptr; ! delta = (sh >= 0) ? sh: -sh; if (sh > 0) { src = &sptr[delta * soffset]; --- 153,166 ---- { ` /* Do the shift for this dimension. */' sh = *hptr; ! if (( sh >= 0 ? sh : -sh ) > len) ! { ! delta = len; ! sh = len; ! } ! else ! delta = (sh >= 0) ? sh: -sh; ! if (sh > 0) { src = &sptr[delta * soffset]; diff -Nrcpad gcc-4.0.1/libgfortran/m4/eoshift3.m4 gcc-4.0.2/libgfortran/m4/eoshift3.m4 *** gcc-4.0.1/libgfortran/m4/eoshift3.m4 Mon May 23 20:03:49 2005 --- gcc-4.0.2/libgfortran/m4/eoshift3.m4 Thu Jul 14 21:17:22 2005 *************** eoshift3_`'atype_kind (gfc_array_char *r *** 85,90 **** --- 85,109 ---- which = 0; size = GFC_DESCRIPTOR_SIZE (ret); + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->base = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + extent[0] = 1; count[0] = 0; *************** eoshift3_`'atype_kind (gfc_array_char *r *** 111,117 **** hstride[n] = h->dim[n].stride; if (bound) ! bstride[n] = bound->dim[n].stride; else bstride[n] = 0; n++; --- 130,136 ---- hstride[n] = h->dim[n].stride; if (bound) ! bstride[n] = bound->dim[n].stride * size; else bstride[n] = 0; n++; *************** eoshift3_`'atype_kind (gfc_array_char *r *** 143,149 **** { ` /* Do the shift for this dimension. */' sh = *hptr; ! delta = (sh >= 0) ? sh: -sh; if (sh > 0) { src = &sptr[delta * soffset]; --- 162,175 ---- { ` /* Do the shift for this dimension. */' sh = *hptr; ! if (( sh >= 0 ? sh : -sh ) > len) ! { ! delta = len; ! sh = len; ! } ! else ! delta = (sh >= 0) ? sh: -sh; ! if (sh > 0) { src = &sptr[delta * soffset]; diff -Nrcpad gcc-4.0.1/libgfortran/m4/in_pack.m4 gcc-4.0.2/libgfortran/m4/in_pack.m4 *** gcc-4.0.1/libgfortran/m4/in_pack.m4 Mon May 23 20:03:49 2005 --- gcc-4.0.2/libgfortran/m4/in_pack.m4 Mon Jul 18 17:40:43 2005 *************** include(iparm.m4)dnl *** 37,45 **** /* Allocates a block of memory with internal_malloc if the array needs repacking. */ ! dnl Only the kind (ie size) is used to name the function. rtype_name * ! `internal_pack_'rtype_kind (rtype * source) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; --- 37,46 ---- /* Allocates a block of memory with internal_malloc if the array needs repacking. */ ! dnl The kind (ie size) is used to name the function for logicals, integers ! dnl and reals. For complex, it's c4 or c8. rtype_name * ! `internal_pack_'rtype_ccode (rtype * source) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; *************** rtype_name * *** 84,90 **** return source->data; /* Allocate storage for the destination. */ ! destptr = (rtype_name *)internal_malloc_size (ssize * rtype_kind); dest = destptr; src = source->data; stride0 = stride[0]; --- 85,91 ---- return source->data; /* Allocate storage for the destination. */ ! destptr = (rtype_name *)internal_malloc_size (ssize * sizeof (rtype_name)); dest = destptr; src = source->data; stride0 = stride[0]; diff -Nrcpad gcc-4.0.1/libgfortran/m4/in_unpack.m4 gcc-4.0.2/libgfortran/m4/in_unpack.m4 *** gcc-4.0.1/libgfortran/m4/in_unpack.m4 Mon May 23 20:03:49 2005 --- gcc-4.0.2/libgfortran/m4/in_unpack.m4 Mon Jul 18 17:40:43 2005 *************** Boston, MA 02111-1307, USA. */ *** 35,43 **** #include "libgfortran.h"' include(iparm.m4)dnl ! dnl Only the kind (ie size) is used to name the function. void ! `internal_unpack_'rtype_kind (rtype * d, const rtype_name * src) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; --- 35,44 ---- #include "libgfortran.h"' include(iparm.m4)dnl ! dnl Only the kind (ie size) is used to name the function for integers, ! dnl reals and logicals. For complex, it's c4 and c8. void ! `internal_unpack_'rtype_ccode (rtype * d, const rtype_name * src) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; *************** void *** 73,79 **** if (dsize != 0) { ! memcpy (dest, src, dsize * rtype_kind); return; } --- 74,80 ---- if (dsize != 0) { ! memcpy (dest, src, dsize * sizeof (rtype_name)); return; } diff -Nrcpad gcc-4.0.1/libgfortran/m4/matmul.m4 gcc-4.0.2/libgfortran/m4/matmul.m4 *** gcc-4.0.1/libgfortran/m4/matmul.m4 Wed Jan 12 21:27:31 2005 --- gcc-4.0.2/libgfortran/m4/matmul.m4 Fri Jul 15 20:47:33 2005 *************** sinclude(`matmul_asm_'rtype_code`.m4')dn *** 169,178 **** ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; } - assert (a->base == 0); - assert (b->base == 0); - assert (retarray->base == 0); - abase = a->data; bbase = b->data; dest = retarray->data; --- 169,174 ---- *************** sinclude(`matmul_asm_'rtype_code`.m4')dn *** 184,190 **** rtype_name *abase_n; rtype_name bbase_yn; ! memset (dest, 0, (sizeof (rtype_name) * size0(retarray))); for (y = 0; y < ycount; y++) { --- 180,193 ---- rtype_name *abase_n; rtype_name bbase_yn; ! if (rystride == ycount) ! memset (dest, 0, (sizeof (rtype_name) * size0((array_t *) retarray))); ! else ! { ! for (y = 0; y < ycount; y++) ! for (x = 0; x < xcount; x++) ! dest[x + y*rystride] = (rtype_name)0; ! } for (y = 0; y < ycount; y++) { diff -Nrcpad gcc-4.0.1/libgfortran/m4/reshape.m4 gcc-4.0.2/libgfortran/m4/reshape.m4 *** gcc-4.0.1/libgfortran/m4/reshape.m4 Mon May 23 20:03:49 2005 --- gcc-4.0.2/libgfortran/m4/reshape.m4 Sun Jul 17 19:12:01 2005 *************** reshape_`'rtype_ccode (rtype * ret, rtyp *** 176,184 **** if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= rtype_kind; ! ssize *= rtype_kind; ! psize *= rtype_kind; reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; --- 176,184 ---- if (rsize != 0 && ssize != 0 && psize != 0) { ! rsize *= sizeof (rtype_name); ! ssize *= sizeof (rtype_name); ! psize *= sizeof (rtype_name); reshape_packed ((char *)ret->data, rsize, (char *)source->data, ssize, pad ? (char *)pad->data : NULL, psize); return; diff -Nrcpad gcc-4.0.1/libgfortran/runtime/compile_options.c gcc-4.0.2/libgfortran/runtime/compile_options.c *** gcc-4.0.1/libgfortran/runtime/compile_options.c Thu Jan 1 00:00:00 1970 --- gcc-4.0.2/libgfortran/runtime/compile_options.c Fri Aug 12 05:58:56 2005 *************** *** 0 **** --- 1,61 ---- + /* Handling of compile-time options that influence the library. + Copyright (C) 2005 Free Software Foundation, Inc. + + This file is part of the GNU Fortran 95 runtime library (libgfortran). + + Libgfortran is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + In addition to the permissions in the GNU General Public License, the + Free Software Foundation gives you unlimited permission to link the + compiled version of this file into combinations with other programs, + and to distribute those combinations without any restriction coming + from the use of this file. (The General Public License restrictions + do apply in other respects; for example, they cover modification of + the file, and distribution when not linked into a combine + executable.) + + Libgfortran is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with libgfortran; see the file COPYING. If not, write to + the Free Software Foundation, 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + + #include "config.h" + + #include "libgfortran.h" + + + /* Useful compile-time options will be stored in here. */ + compile_options_t compile_options; + + + /* Prototypes */ + extern void set_std (GFC_INTEGER_4, GFC_INTEGER_4); + export_proto(set_std); + + + void + set_std (GFC_INTEGER_4 warn_std, GFC_INTEGER_4 allow_std) + { + compile_options.warn_std = warn_std; + compile_options.allow_std = allow_std; + } + + + /* Default values for the compile-time options. Keep in sync with + gcc/fortran/options.c (gfc_init_options). */ + void + init_compile_options (void) + { + compile_options.warn_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL + | GFC_STD_F2003 | GFC_STD_LEGACY; + compile_options.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL + | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F77 | GFC_STD_GNU | GFC_STD_LEGACY; + } diff -Nrcpad gcc-4.0.1/libgfortran/runtime/error.c gcc-4.0.2/libgfortran/runtime/error.c *** gcc-4.0.1/libgfortran/runtime/error.c Wed Jan 12 21:27:31 2005 --- gcc-4.0.2/libgfortran/runtime/error.c Thu Aug 11 13:53:22 2005 *************** generate_error (int family, const char * *** 488,490 **** --- 488,516 ---- runtime_error (message); } + + + + /* Possibly issue a warning/error about use of a nonstandard (or deleted) + feature. An error/warning will be issued if the currently selected + standard does not contain the requested bits. */ + + try + notify_std (int std, const char * message) + { + int warning; + + warning = compile_options.warn_std & std; + if ((compile_options.allow_std & std) != 0 && !warning) + return SUCCESS; + + show_locus (); + if (!warning) + { + st_printf ("Fortran runtime error: %s\n", message); + sys_exit (2); + } + else + st_printf ("Fortran runtime warning: %s\n", message); + return FAILURE; + } diff -Nrcpad gcc-4.0.1/libgfortran/runtime/in_pack_generic.c gcc-4.0.2/libgfortran/runtime/in_pack_generic.c *** gcc-4.0.1/libgfortran/runtime/in_pack_generic.c Fri May 27 19:08:37 2005 --- gcc-4.0.2/libgfortran/runtime/in_pack_generic.c Mon Jul 18 17:40:44 2005 *************** internal_pack (gfc_array_char * source) *** 52,57 **** --- 52,58 ---- int n; int packed; index_type size; + int type; if (source->dim[0].stride == 0) { *************** internal_pack (gfc_array_char * source) *** 59,72 **** return source->data; } size = GFC_DESCRIPTOR_SIZE (source); ! switch (size) { ! case 4: ! return internal_pack_4 ((gfc_array_i4 *)source); ! case 8: ! return internal_pack_8 ((gfc_array_i8 *)source); } dim = GFC_DESCRIPTOR_RANK (source); --- 60,95 ---- return source->data; } + type = GFC_DESCRIPTOR_TYPE (source); size = GFC_DESCRIPTOR_SIZE (source); ! switch (type) { ! case GFC_DTYPE_INTEGER: ! case GFC_DTYPE_LOGICAL: ! case GFC_DTYPE_REAL: ! switch (size) ! { ! case 4: ! return internal_pack_4 ((gfc_array_i4 *)source); ! ! case 8: ! return internal_pack_8 ((gfc_array_i8 *)source); ! } ! break; ! case GFC_DTYPE_COMPLEX: ! switch (size) ! { ! case 8: ! return internal_pack_c4 ((gfc_array_c4 *)source); ! ! case 16: ! return internal_pack_c8 ((gfc_array_c8 *)source); ! } ! break; ! ! default: ! break; } dim = GFC_DESCRIPTOR_RANK (source); diff -Nrcpad gcc-4.0.1/libgfortran/runtime/in_unpack_generic.c gcc-4.0.2/libgfortran/runtime/in_unpack_generic.c *** gcc-4.0.1/libgfortran/runtime/in_unpack_generic.c Fri May 27 19:08:38 2005 --- gcc-4.0.2/libgfortran/runtime/in_unpack_generic.c Mon Jul 18 17:40:44 2005 *************** internal_unpack (gfc_array_char * d, con *** 50,71 **** const char *src; int n; int size; dest = d->data; /* This check may be redundant, but do it anyway. */ if (s == dest || !s) return; size = GFC_DESCRIPTOR_SIZE (d); ! switch (size) { ! case 4: ! internal_unpack_4 ((gfc_array_i4 *)d, (const GFC_INTEGER_4 *)s); ! return; ! case 8: ! internal_unpack_8 ((gfc_array_i8 *)d, (const GFC_INTEGER_8 *)s); ! return; } if (d->dim[0].stride == 0) --- 50,94 ---- const char *src; int n; int size; + int type; dest = d->data; /* This check may be redundant, but do it anyway. */ if (s == dest || !s) return; + type = GFC_DESCRIPTOR_TYPE (d); size = GFC_DESCRIPTOR_SIZE (d); ! switch (type) { ! case GFC_DTYPE_INTEGER: ! case GFC_DTYPE_LOGICAL: ! case GFC_DTYPE_REAL: ! switch (size) ! { ! case 4: ! internal_unpack_4 ((gfc_array_i4 *)d, (const GFC_INTEGER_4 *)s); ! return; ! case 8: ! internal_unpack_8 ((gfc_array_i8 *)d, (const GFC_INTEGER_8 *)s); ! return; ! } ! break; ! ! case GFC_DTYPE_COMPLEX: ! switch (size) ! { ! case 8: ! internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s); ! return; ! ! case 16: ! internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s); ! return; ! } ! default: ! break; } if (d->dim[0].stride == 0) diff -Nrcpad gcc-4.0.1/libgfortran/runtime/main.c gcc-4.0.2/libgfortran/runtime/main.c *** gcc-4.0.1/libgfortran/runtime/main.c Wed Jan 12 21:27:31 2005 --- gcc-4.0.2/libgfortran/runtime/main.c Thu Aug 11 13:53:22 2005 *************** init (void) *** 96,101 **** --- 96,102 ---- init_variables (); init_units (); + init_compile_options (); #ifdef DEBUG /* Check for special command lines. */ diff -Nrcpad gcc-4.0.1/libgfortran/runtime/string.c gcc-4.0.2/libgfortran/runtime/string.c *** gcc-4.0.1/libgfortran/runtime/string.c Wed Apr 13 20:48:14 2005 --- gcc-4.0.2/libgfortran/runtime/string.c Tue Jul 12 01:50:37 2005 *************** Boston, MA 02111-1307, USA. */ *** 40,46 **** static int compare0 (const char *s1, int s1_len, const char *s2) { - int i; int len; /* Strip trailing blanks from the Fortran string. */ --- 40,45 ----