diff -Nrcpad gcc-4.4.0/gcc/fortran/ChangeLog gcc-4.4.1/gcc/fortran/ChangeLog *** gcc-4.4.0/gcc/fortran/ChangeLog Tue Apr 21 08:44:29 2009 --- gcc-4.4.1/gcc/fortran/ChangeLog Wed Jul 22 07:28:47 2009 *************** *** 1,3 **** --- 1,141 ---- + 2009-07-22 Release Manager + + * GCC 4.4.1 released. + + 2009-07-09 Paul Thomas + + PR fortran/40440 + * trans-expr.c (gfc_conv_procedure_call): Do not deallocate + allocatable components if the argument is a pointer. + + 2009-07-05 Paul Thomas + + PR fortran/40551 + * dependency.h : Add second bool* argument to prototype of + gfc_full_array_ref_p. + * dependency.c (gfc_full_array_ref_p): If second argument is + present, return true if last dimension of reference is an + element or has unity stride. + * trans-array.c : Add NULL second argument to references to + gfc_full_array_ref_p. + * trans-expr.c : The same, except for; + (gfc_trans_arrayfunc_assign): Return fail if lhs reference + is not a full array or a contiguous section. + + 2009-07-04 Jakub Jelinek + + * trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): For integer + maxloc initialize limit to -huge-1 rather than just -huge. + + 2009-07-03 Jerry DeLisle + + PR fortran/40638 + * trans-io.c (set_parameter_value): Don't build un-necessary run-time + checks for units of KIND less than 4. + + 2009-06-29 Paul Thomas + + PR fortran/40443 + * interface.c (gfc_search_interface): Hold back a match to an + elementary procedure until all other possibilities are + exhausted. + + 2009-06-20 Paul Thomas + + PR fortran/39800 + * resolve.c (is_sym_host_assoc): New function. + (resolve_fl_derived): Call it when checking PRIVATE components + of PUBLIC derived types. Change gfc_error to a gfc_notify_std + with std=f2003. + (resolve_fl_namelist): Call it twice to check for host + association. + + 2009-06-20 Paul Thomas + + PR fortran/40402 + * resolve.c (next_data_value): It is an error if the value is + not constant. + + 2009-06-14 Richard Guenther + + Backport from mainline + 2009-05-18 Richard Guenther + + PR fortran/40168 + * trans-expr.c (gfc_trans_zero_assign): For local array + destinations use an assignment from an empty constructor. + + 2009-06-04 Steven G. Kargl + + PR fortran/39893 + fortran/data.c (gfc_assign_data_value): If the lvalue is an + assumed character length entity in a data statement, then + return FAILURE to prevent segmentation fault. + + 2009-06-03 Francois-Xavier Coudert + + PR fortran/40019 + * trans-types.c (gfc_build_uint_type): Make nonstatic. + * trans.h (gfor_fndecl_clz128, gfor_fndecl_ctz128): New prototypes. + * trans-types.h (gfc_build_uint_type): Add prototype. + * trans-decl.c (gfc_build_intrinsic_function_decls): Build + gfor_fndecl_clz128 and gfor_fndecl_ctz128. + * trans-intrinsic.c (gfc_conv_intrinsic_leadz, + gfc_conv_intrinsic_trailz): Call the right builtins or library + functions, and cast arguments to unsigned types first. + * simplify.c (gfc_simplify_leadz): Deal with negative arguments. + + 2009-05-22 Francois-Xavier Coudert + + PR fortran/40195 + * module.c (read_md5_from_module_file): Close file before returning. + + 2009-05-10 Paul Thomas + + Backport from mainline: + PR fortran/40018 + * trans-array.c (gfc_trans_array_constructor_value): Fold + convert numeric constants. + (gfc_build_constant_array_constructor): The same. + + 2009-05-10 Paul Thomas + + Backport from mainline: + PR fortran/38863 + * trans-expr.c (gfc_conv_operator_assign): Remove function. + * trans.h : Remove prototype for gfc_conv_operator_assign. + * trans-stmt.c (gfc_conv_elemental_dependencies): Initialize + derivde types with intent(out). + (gfc_trans_call): Add mask, count1 and invert arguments. Add + code to use mask for WHERE assignments. + (gfc_trans_forall_1): Use new arguments for gfc_trans_call. + (gfc_trans_where_assign): The gfc_symbol argument is replaced + by the corresponding code. If this has a resolved_sym, then + gfc_trans_call is called. The call to gfc_conv_operator_assign + is removed. + (gfc_trans_where_2): Change the last argument in the call to + gfc_trans_where_assign. + * trans-stmt.h : Modify prototype for gfc_trans_call. + * trans.c (gfc_trans_code): Use new args for gfc_trans_call. + + 2009-05-10 Paul Thomas + + Backport from mainline: + PR fortran/39879 + * trans_expr.c (gfc_conv_procedure_call): Deep copy a derived + type parentheses argument if it is a variable with allocatable + components. + + 2009-04-22 Ulrich Weigand + + Backport from mainline: + 2009-03-30 Ulrich Weigand + + * f95-lang.c (gfc_init_builtin_functions): Define BUILT_IN_HUGE_VAL + family of intrinsics instead of BUILT_IN_INF family. + * trans-intrinsics.c (gfc_conv_intrinsic_nearest): Use + BUILT_IN_HUGE_VAL instead of BUILT_IN_INF. + 2009-04-21 Release Manager * GCC 4.4.0 released. diff -Nrcpad gcc-4.4.0/gcc/fortran/data.c gcc-4.4.1/gcc/fortran/data.c *** gcc-4.4.0/gcc/fortran/data.c Tue Jul 29 00:45:52 2008 --- gcc-4.4.1/gcc/fortran/data.c Thu Jun 4 17:01:45 2009 *************** gfc_assign_data_value (gfc_expr *lvalue, *** 416,422 **** } if (ref || last_ts->type == BT_CHARACTER) ! expr = create_character_intializer (init, last_ts, ref, rvalue); else { /* Overwriting an existing initializer is non-standard but usually only --- 416,426 ---- } if (ref || last_ts->type == BT_CHARACTER) ! { ! if (lvalue->ts.cl->length == NULL && !(ref && ref->u.ss.length != NULL)) ! return FAILURE; ! expr = create_character_intializer (init, last_ts, ref, rvalue); ! } else { /* Overwriting an existing initializer is non-standard but usually only diff -Nrcpad gcc-4.4.0/gcc/fortran/dependency.c gcc-4.4.1/gcc/fortran/dependency.c *** gcc-4.4.0/gcc/fortran/dependency.c Fri Jan 9 23:47:55 2009 --- gcc-4.4.1/gcc/fortran/dependency.c Sun Jul 5 19:06:05 2009 *************** gfc_check_element_vs_element (gfc_ref *l *** 1186,1202 **** /* Determine if an array ref, usually an array section specifies the ! entire array. */ bool ! gfc_full_array_ref_p (gfc_ref *ref) { int i; if (ref->type != REF_ARRAY) return false; if (ref->u.ar.type == AR_FULL) ! return true; if (ref->u.ar.type != AR_SECTION) return false; if (ref->next) --- 1186,1213 ---- /* Determine if an array ref, usually an array section specifies the ! entire array. In addition, if the second, pointer argument is ! provided, the function will return true if the reference is ! contiguous; eg. (:, 1) gives true but (1,:) gives false. */ bool ! gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous) { int i; + bool lbound_OK = true; + bool ubound_OK = true; + + if (contiguous) + *contiguous = false; if (ref->type != REF_ARRAY) return false; if (ref->u.ar.type == AR_FULL) ! { ! if (contiguous) ! *contiguous = true; ! return true; ! } if (ref->u.ar.type != AR_SECTION) return false; if (ref->next) *************** gfc_full_array_ref_p (gfc_ref *ref) *** 1209,1214 **** --- 1220,1229 ---- the correct element. */ if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) { + /* This is a contiguous reference. */ + if (contiguous) + *contiguous = (i + 1 == ref->u.ar.dimen); + if (!ref->u.ar.as || !ref->u.ar.as->lower[i] || !ref->u.ar.as->upper[i] *************** gfc_full_array_ref_p (gfc_ref *ref) *** 1228,1244 **** || !ref->u.ar.as->lower[i] || gfc_dep_compare_expr (ref->u.ar.start[i], ref->u.ar.as->lower[i]))) ! return false; /* Check the upper bound. */ if (ref->u.ar.end[i] && (!ref->u.ar.as || !ref->u.ar.as->upper[i] || gfc_dep_compare_expr (ref->u.ar.end[i], ref->u.ar.as->upper[i]))) ! return false; /* Check the stride. */ if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) return false; } return true; } --- 1243,1266 ---- || !ref->u.ar.as->lower[i] || gfc_dep_compare_expr (ref->u.ar.start[i], ref->u.ar.as->lower[i]))) ! lbound_OK = false; /* Check the upper bound. */ if (ref->u.ar.end[i] && (!ref->u.ar.as || !ref->u.ar.as->upper[i] || gfc_dep_compare_expr (ref->u.ar.end[i], ref->u.ar.as->upper[i]))) ! ubound_OK = false; /* Check the stride. */ if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) return false; + + /* This is a contiguous reference. */ + if (contiguous) + *contiguous = (i + 1 == ref->u.ar.dimen); + + if (!lbound_OK || !ubound_OK) + return false; } return true; } *************** gfc_dep_resolver (gfc_ref *lref, gfc_ref *** 1284,1294 **** if (lref->u.ar.dimen != rref->u.ar.dimen) { if (lref->u.ar.type == AR_FULL) ! fin_dep = gfc_full_array_ref_p (rref) ? GFC_DEP_EQUAL ! : GFC_DEP_OVERLAP; else if (rref->u.ar.type == AR_FULL) ! fin_dep = gfc_full_array_ref_p (lref) ? GFC_DEP_EQUAL ! : GFC_DEP_OVERLAP; else return 1; break; --- 1306,1316 ---- if (lref->u.ar.dimen != rref->u.ar.dimen) { if (lref->u.ar.type == AR_FULL) ! fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL ! : GFC_DEP_OVERLAP; else if (rref->u.ar.type == AR_FULL) ! fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL ! : GFC_DEP_OVERLAP; else return 1; break; diff -Nrcpad gcc-4.4.0/gcc/fortran/dependency.h gcc-4.4.1/gcc/fortran/dependency.h *** gcc-4.4.0/gcc/fortran/dependency.h Sun Nov 16 22:45:10 2008 --- gcc-4.4.1/gcc/fortran/dependency.h Sun Jul 5 19:06:05 2009 *************** gfc_dep_check; *** 33,39 **** /*********************** Functions prototypes **************************/ bool gfc_ref_needs_temporary_p (gfc_ref *); ! bool gfc_full_array_ref_p (gfc_ref *); gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *); int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *, gfc_actual_arglist *, gfc_dep_check); --- 33,39 ---- /*********************** Functions prototypes **************************/ bool gfc_ref_needs_temporary_p (gfc_ref *); ! bool gfc_full_array_ref_p (gfc_ref *, bool *); gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *); int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *, gfc_actual_arglist *, gfc_dep_check); diff -Nrcpad gcc-4.4.0/gcc/fortran/f95-lang.c gcc-4.4.1/gcc/fortran/f95-lang.c *** gcc-4.4.0/gcc/fortran/f95-lang.c Tue Oct 7 18:15:32 2008 --- gcc-4.4.1/gcc/fortran/f95-lang.c Wed Apr 22 11:37:04 2009 *************** gfc_init_builtin_functions (void) *** 917,928 **** gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], BUILT_IN_FMODF, "fmodf", true); ! gfc_define_builtin ("__builtin_infl", mfunc_longdouble[3], ! BUILT_IN_INFL, "__builtin_infl", true); ! gfc_define_builtin ("__builtin_inf", mfunc_double[3], ! BUILT_IN_INF, "__builtin_inf", true); ! gfc_define_builtin ("__builtin_inff", mfunc_float[3], ! BUILT_IN_INFF, "__builtin_inff", true); /* lround{f,,l} and llround{f,,l} */ type = tree_cons (NULL_TREE, float_type_node, void_list_node); --- 917,928 ---- gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], BUILT_IN_FMODF, "fmodf", true); ! gfc_define_builtin ("__builtin_huge_vall", mfunc_longdouble[3], ! BUILT_IN_HUGE_VALL, "__builtin_huge_vall", true); ! gfc_define_builtin ("__builtin_huge_val", mfunc_double[3], ! BUILT_IN_HUGE_VAL, "__builtin_huge_val", true); ! gfc_define_builtin ("__builtin_huge_valf", mfunc_float[3], ! BUILT_IN_HUGE_VALF, "__builtin_huge_valf", true); /* lround{f,,l} and llround{f,,l} */ type = tree_cons (NULL_TREE, float_type_node, void_list_node); diff -Nrcpad gcc-4.4.0/gcc/fortran/gfortran.info gcc-4.4.1/gcc/fortran/gfortran.info *** gcc-4.4.0/gcc/fortran/gfortran.info Tue Apr 21 09:55:58 2009 --- gcc-4.4.1/gcc/fortran/gfortran.info Wed Jul 22 08:33:04 2009 *************** *** 1,5 **** ! This is doc/gfortran.info, produced by makeinfo version 4.12 from ! /usr/src/gcc-4.4.0/gcc-4.4.0/gcc/fortran/gfortran.texi. Copyright (C) 1999-2008 Free Software Foundation, Inc. --- 1,5 ---- ! This is doc/gfortran.info, produced by makeinfo version 4.13 from ! /d/gcc-4.4.1/gcc-4.4.1/gcc/fortran/gfortran.texi. Copyright (C) 1999-2008 Free Software Foundation, Inc. *************** Keyword Index *** 14739,15040 ****  Tag Table: ! Node: Top1996 ! Node: Introduction3311 ! Node: About GNU Fortran4058 ! Node: GNU Fortran and GCC8086 ! Node: Preprocessing and conditional compilation10198 ! Node: GNU Fortran and G7711839 ! Node: Project Status12412 ! Node: Standards14927 ! Node: Invoking GNU Fortran16138 ! Node: Option Summary17861 ! Node: Fortran Dialect Options21349 ! Node: Preprocessing Options28159 ! Node: Error and Warning Options36285 ! Node: Debugging Options43712 ! Node: Directory Options45875 ! Node: Link Options47390 ! Node: Runtime Options48014 ! Node: Code Gen Options50094 ! Node: Environment Variables62319 ! Node: Runtime62924 ! Node: GFORTRAN_STDIN_UNIT64152 ! Node: GFORTRAN_STDOUT_UNIT64519 ! Node: GFORTRAN_STDERR_UNIT64920 ! Node: GFORTRAN_USE_STDERR65318 ! Node: GFORTRAN_TMPDIR65763 ! Node: GFORTRAN_UNBUFFERED_ALL66204 ! Node: GFORTRAN_UNBUFFERED_PRECONNECTED66727 ! Node: GFORTRAN_SHOW_LOCUS67369 ! Node: GFORTRAN_OPTIONAL_PLUS67863 ! Node: GFORTRAN_DEFAULT_RECL68338 ! Node: GFORTRAN_LIST_SEPARATOR68829 ! Node: GFORTRAN_CONVERT_UNIT69438 ! Node: GFORTRAN_ERROR_DUMPCORE72300 ! Node: GFORTRAN_ERROR_BACKTRACE72847 ! Node: Fortran 2003 and 2008 status73398 ! Node: Fortran 2003 status73638 ! Node: Fortran 2008 status75329 ! Node: Compiler Characteristics76298 ! Node: KIND Type Parameters76636 ! Node: Extensions77563 ! Node: Extensions implemented in GNU Fortran78162 ! Node: Old-style kind specifications79496 ! Node: Old-style variable initialization80602 ! Node: Extensions to namelist81914 ! Node: X format descriptor without count field83910 ! Node: Commas in FORMAT specifications84437 ! Node: Missing period in FORMAT specifications84954 ! Node: I/O item lists85516 ! Node: BOZ literal constants85905 ! Node: Real array indices88474 ! Node: Unary operators88771 ! Node: Implicitly convert LOGICAL and INTEGER values89185 ! Node: Hollerith constants support90145 ! Node: Cray pointers91917 ! Node: CONVERT specifier97327 ! Node: OpenMP99325 ! Node: Argument list functions101580 ! Node: Extensions not implemented in GNU Fortran103174 ! Node: STRUCTURE and RECORD104026 ! Node: ENCODE and DECODE statements106082 ! Node: Intrinsic Procedures107400 ! Node: Introduction to Intrinsics121090 ! Node: ABORT123442 ! Node: ABS124199 ! Node: ACCESS125701 ! Node: ACHAR127622 ! Node: ACOS128823 ! Node: ACOSH129821 ! Node: ADJUSTL130698 ! Node: ADJUSTR131639 ! Node: AIMAG132586 ! Node: AINT133906 ! Node: ALARM135378 ! Node: ALL137012 ! Node: ALLOCATED138930 ! Node: AND139811 ! Node: ANINT141108 ! Node: ANY142471 ! Node: ASIN144401 ! Node: ASINH145413 ! Node: ASSOCIATED146295 ! Node: ATAN149300 ! Node: ATAN2150189 ! Node: ATANH151533 ! Node: BESSEL_J0152413 ! Node: BESSEL_J1153457 ! Node: BESSEL_JN154509 ! Node: BESSEL_Y0155676 ! Node: BESSEL_Y1156676 ! Node: BESSEL_YN157676 ! Node: BIT_SIZE158893 ! Node: BTEST159722 ! Node: C_ASSOCIATED160610 ! Node: C_FUNLOC161819 ! Node: C_F_PROCPOINTER163188 ! Node: C_F_POINTER164817 ! Node: C_LOC166235 ! Node: C_SIZEOF167352 ! Node: CEILING168705 ! Node: CHAR169710 ! Node: CHDIR170774 ! Node: CHMOD171942 ! Node: CMPLX173737 ! Node: COMMAND_ARGUMENT_COUNT175201 ! Node: COMPLEX176108 ! Node: CONJG177251 ! Node: COS178261 ! Node: COSH179532 ! Node: COUNT180501 ! Node: CPU_TIME182357 ! Node: CSHIFT183711 ! Node: CTIME185367 ! Node: DATE_AND_TIME186626 ! Node: DBLE189087 ! Node: DCMPLX189911 ! Node: DFLOAT191105 ! Node: DIGITS191799 ! Node: DIM192765 ! Node: DOT_PRODUCT193908 ! Node: DPROD195564 ! Node: DREAL196290 ! Node: DTIME196954 ! Node: EOSHIFT199760 ! Node: EPSILON201833 ! Node: ERF202559 ! Node: ERFC203333 ! Node: ERFC_SCALED204137 ! Node: ETIME204829 ! Node: EXIT207060 ! Node: EXP207919 ! Node: EXPONENT209077 ! Node: FDATE209827 ! Node: FLOAT211102 ! Node: FGET211816 ! Node: FGETC213610 ! Node: FLOOR215378 ! Node: FLUSH216362 ! Node: FNUM217000 ! Node: FPUT217722 ! Node: FPUTC219323 ! Node: FRACTION221063 ! Node: FREE221964 ! Node: FSEEK222801 ! Node: FSTAT225095 ! Node: FTELL226135 ! Node: GAMMA227113 ! Node: GERROR228154 ! Node: GETARG228873 ! Node: GET_COMMAND230637 ! Node: GET_COMMAND_ARGUMENT231583 ! Node: GETCWD233551 ! Node: GETENV234497 ! Node: GET_ENVIRONMENT_VARIABLE235719 ! Node: GETGID237419 ! Node: GETLOG237954 ! Node: GETPID238812 ! Node: GETUID239540 ! Node: GMTIME240054 ! Node: HOSTNM241543 ! Node: HUGE242459 ! Node: HYPOT243178 ! Node: IACHAR243998 ! Node: IAND245178 ! Node: IARGC246165 ! Node: IBCLR247188 ! Node: IBITS247849 ! Node: IBSET248764 ! Node: ICHAR249420 ! Node: IDATE251401 ! Node: IEOR252428 ! Node: IERRNO253304 ! Node: INDEX intrinsic253859 ! Node: INT255205 ! Node: INT2256792 ! Node: INT8257557 ! Node: IOR258269 ! Node: IRAND259119 ! Node: IS_IOSTAT_END260471 ! Node: IS_IOSTAT_EOR261566 ! Node: ISATTY262691 ! Node: ISHFT263474 ! Node: ISHFTC264454 ! Node: ISNAN265670 ! Node: ITIME266418 ! Node: KILL267443 ! Node: KIND268316 ! Node: LBOUND269161 ! Node: LEADZ270473 ! Node: LEN271277 ! Node: LEN_TRIM272368 ! Node: LGE273356 ! Node: LGT274669 ! Node: LINK275946 ! Node: LLE276981 ! Node: LLT278285 ! Node: LNBLNK279555 ! Node: LOC280331 ! Node: LOG281062 ! Node: LOG10282353 ! Node: LOG_GAMMA283325 ! Node: LOGICAL284413 ! Node: LONG285217 ! Node: LSHIFT285973 ! Node: LSTAT286927 ! Node: LTIME288081 ! Node: MALLOC289496 ! Node: MATMUL290956 ! Node: MAX292046 ! Node: MAXEXPONENT293545 ! Node: MAXLOC294361 ! Node: MAXVAL296410 ! Node: MCLOCK298073 ! Node: MCLOCK8299076 ! Node: MERGE300290 ! Node: MIN301032 ! Node: MINEXPONENT302528 ! Node: MINLOC303158 ! Node: MINVAL305207 ! Node: MOD306889 ! Node: MODULO308381 ! Node: MOVE_ALLOC309595 ! Node: MVBITS310619 ! Node: NEAREST311678 ! Node: NEW_LINE312801 ! Node: NINT313572 ! Node: NOT314840 ! Node: NULL315423 ! Node: OR316321 ! Node: PACK317599 ! Node: PERROR319591 ! Node: PRECISION320213 ! Node: PRESENT321039 ! Node: PRODUCT322145 ! Node: RADIX323670 ! Node: RAN324447 ! Node: RAND324903 ! Node: RANDOM_NUMBER326238 ! Node: RANDOM_SEED327956 ! Node: RANGE329839 ! Node: REAL330463 ! Node: RENAME331905 ! Node: REPEAT332924 ! Node: RESHAPE333650 ! Node: RRSPACING335119 ! Node: RSHIFT335812 ! Node: SCALE336774 ! Node: SCAN337548 ! Node: SECNDS339098 ! Node: SECOND340186 ! Node: SELECTED_CHAR_KIND341062 ! Node: SELECTED_INT_KIND342059 ! Node: SELECTED_REAL_KIND343234 ! Node: SET_EXPONENT345173 ! Node: SHAPE346169 ! Node: SIGN347282 ! Node: SIGNAL348365 ! Node: SIN349862 ! Node: SINH350904 ! Node: SIZE351716 ! Node: SIZEOF353024 ! Node: SLEEP354318 ! Node: SNGL354875 ! Node: SPACING355546 ! Node: SPREAD356558 ! Node: SQRT357703 ! Node: SRAND358942 ! Node: STAT360110 ! Node: SUM363222 ! Node: SYMLNK364691 ! Node: SYSTEM365823 ! Node: SYSTEM_CLOCK366771 ! Node: TAN368115 ! Node: TANH368951 ! Node: TIME369818 ! Node: TIME8370922 ! Node: TINY372059 ! Node: TRAILZ372659 ! Node: TRANSFER373444 ! Node: TRANSPOSE375478 ! Node: TRIM376165 ! Node: TTYNAM377022 ! Node: UBOUND377937 ! Node: UMASK379306 ! Node: UNLINK379861 ! Node: UNPACK380838 ! Node: VERIFY382126 ! Node: XOR383842 ! Node: Intrinsic Modules385150 ! Node: Contributing390941 ! Node: Contributors391793 ! Node: Projects393416 ! Node: Proposed Extensions394219 ! Node: Copying396270 ! Node: GNU Free Documentation License433834 ! Node: Funding456246 ! Node: Option Index458771 ! Node: Keyword Index470653  End Tag Table --- 14739,15040 ----  Tag Table: ! Node: Top1990 ! Node: Introduction3305 ! Node: About GNU Fortran4052 ! Node: GNU Fortran and GCC8080 ! Node: Preprocessing and conditional compilation10192 ! Node: GNU Fortran and G7711833 ! Node: Project Status12406 ! Node: Standards14921 ! Node: Invoking GNU Fortran16132 ! Node: Option Summary17855 ! Node: Fortran Dialect Options21343 ! Node: Preprocessing Options28153 ! Node: Error and Warning Options36279 ! Node: Debugging Options43706 ! Node: Directory Options45869 ! Node: Link Options47384 ! Node: Runtime Options48008 ! Node: Code Gen Options50088 ! Node: Environment Variables62313 ! Node: Runtime62918 ! Node: GFORTRAN_STDIN_UNIT64146 ! Node: GFORTRAN_STDOUT_UNIT64513 ! Node: GFORTRAN_STDERR_UNIT64914 ! Node: GFORTRAN_USE_STDERR65312 ! Node: GFORTRAN_TMPDIR65757 ! Node: GFORTRAN_UNBUFFERED_ALL66198 ! Node: GFORTRAN_UNBUFFERED_PRECONNECTED66721 ! Node: GFORTRAN_SHOW_LOCUS67363 ! Node: GFORTRAN_OPTIONAL_PLUS67857 ! Node: GFORTRAN_DEFAULT_RECL68332 ! Node: GFORTRAN_LIST_SEPARATOR68823 ! Node: GFORTRAN_CONVERT_UNIT69432 ! Node: GFORTRAN_ERROR_DUMPCORE72294 ! Node: GFORTRAN_ERROR_BACKTRACE72841 ! Node: Fortran 2003 and 2008 status73392 ! Node: Fortran 2003 status73632 ! Node: Fortran 2008 status75323 ! Node: Compiler Characteristics76292 ! Node: KIND Type Parameters76630 ! Node: Extensions77557 ! Node: Extensions implemented in GNU Fortran78156 ! Node: Old-style kind specifications79490 ! Node: Old-style variable initialization80596 ! Node: Extensions to namelist81908 ! Node: X format descriptor without count field83904 ! Node: Commas in FORMAT specifications84431 ! Node: Missing period in FORMAT specifications84948 ! Node: I/O item lists85510 ! Node: BOZ literal constants85899 ! Node: Real array indices88468 ! Node: Unary operators88765 ! Node: Implicitly convert LOGICAL and INTEGER values89179 ! Node: Hollerith constants support90139 ! Node: Cray pointers91911 ! Node: CONVERT specifier97321 ! Node: OpenMP99319 ! Node: Argument list functions101574 ! Node: Extensions not implemented in GNU Fortran103168 ! Node: STRUCTURE and RECORD104020 ! Node: ENCODE and DECODE statements106076 ! Node: Intrinsic Procedures107394 ! Node: Introduction to Intrinsics121084 ! Node: ABORT123436 ! Node: ABS124193 ! Node: ACCESS125695 ! Node: ACHAR127616 ! Node: ACOS128817 ! Node: ACOSH129815 ! Node: ADJUSTL130692 ! Node: ADJUSTR131633 ! Node: AIMAG132580 ! Node: AINT133900 ! Node: ALARM135372 ! Node: ALL137006 ! Node: ALLOCATED138924 ! Node: AND139805 ! Node: ANINT141102 ! Node: ANY142465 ! Node: ASIN144395 ! Node: ASINH145407 ! Node: ASSOCIATED146289 ! Node: ATAN149294 ! Node: ATAN2150183 ! Node: ATANH151527 ! Node: BESSEL_J0152407 ! Node: BESSEL_J1153451 ! Node: BESSEL_JN154503 ! Node: BESSEL_Y0155670 ! Node: BESSEL_Y1156670 ! Node: BESSEL_YN157670 ! Node: BIT_SIZE158887 ! Node: BTEST159716 ! Node: C_ASSOCIATED160604 ! Node: C_FUNLOC161813 ! Node: C_F_PROCPOINTER163182 ! Node: C_F_POINTER164811 ! Node: C_LOC166229 ! Node: C_SIZEOF167346 ! Node: CEILING168699 ! Node: CHAR169704 ! Node: CHDIR170768 ! Node: CHMOD171936 ! Node: CMPLX173731 ! Node: COMMAND_ARGUMENT_COUNT175195 ! Node: COMPLEX176102 ! Node: CONJG177245 ! Node: COS178255 ! Node: COSH179526 ! Node: COUNT180495 ! Node: CPU_TIME182351 ! Node: CSHIFT183705 ! Node: CTIME185361 ! Node: DATE_AND_TIME186620 ! Node: DBLE189081 ! Node: DCMPLX189905 ! Node: DFLOAT191099 ! Node: DIGITS191793 ! Node: DIM192759 ! Node: DOT_PRODUCT193902 ! Node: DPROD195558 ! Node: DREAL196284 ! Node: DTIME196948 ! Node: EOSHIFT199754 ! Node: EPSILON201827 ! Node: ERF202553 ! Node: ERFC203327 ! Node: ERFC_SCALED204131 ! Node: ETIME204823 ! Node: EXIT207054 ! Node: EXP207913 ! Node: EXPONENT209071 ! Node: FDATE209821 ! Node: FLOAT211096 ! Node: FGET211810 ! Node: FGETC213604 ! Node: FLOOR215372 ! Node: FLUSH216356 ! Node: FNUM216994 ! Node: FPUT217716 ! Node: FPUTC219317 ! Node: FRACTION221057 ! Node: FREE221958 ! Node: FSEEK222795 ! Node: FSTAT225089 ! Node: FTELL226129 ! Node: GAMMA227107 ! Node: GERROR228148 ! Node: GETARG228867 ! Node: GET_COMMAND230631 ! Node: GET_COMMAND_ARGUMENT231577 ! Node: GETCWD233545 ! Node: GETENV234491 ! Node: GET_ENVIRONMENT_VARIABLE235713 ! Node: GETGID237413 ! Node: GETLOG237948 ! Node: GETPID238806 ! Node: GETUID239534 ! Node: GMTIME240048 ! Node: HOSTNM241537 ! Node: HUGE242453 ! Node: HYPOT243172 ! Node: IACHAR243992 ! Node: IAND245172 ! Node: IARGC246159 ! Node: IBCLR247182 ! Node: IBITS247843 ! Node: IBSET248758 ! Node: ICHAR249414 ! Node: IDATE251395 ! Node: IEOR252422 ! Node: IERRNO253298 ! Node: INDEX intrinsic253853 ! Node: INT255199 ! Node: INT2256786 ! Node: INT8257551 ! Node: IOR258263 ! Node: IRAND259113 ! Node: IS_IOSTAT_END260465 ! Node: IS_IOSTAT_EOR261560 ! Node: ISATTY262685 ! Node: ISHFT263468 ! Node: ISHFTC264448 ! Node: ISNAN265664 ! Node: ITIME266412 ! Node: KILL267437 ! Node: KIND268310 ! Node: LBOUND269155 ! Node: LEADZ270467 ! Node: LEN271271 ! Node: LEN_TRIM272362 ! Node: LGE273350 ! Node: LGT274663 ! Node: LINK275940 ! Node: LLE276975 ! Node: LLT278279 ! Node: LNBLNK279549 ! Node: LOC280325 ! Node: LOG281056 ! Node: LOG10282347 ! Node: LOG_GAMMA283319 ! Node: LOGICAL284407 ! Node: LONG285211 ! Node: LSHIFT285967 ! Node: LSTAT286921 ! Node: LTIME288075 ! Node: MALLOC289490 ! Node: MATMUL290950 ! Node: MAX292040 ! Node: MAXEXPONENT293539 ! Node: MAXLOC294355 ! Node: MAXVAL296404 ! Node: MCLOCK298067 ! Node: MCLOCK8299070 ! Node: MERGE300284 ! Node: MIN301026 ! Node: MINEXPONENT302522 ! Node: MINLOC303152 ! Node: MINVAL305201 ! Node: MOD306883 ! Node: MODULO308375 ! Node: MOVE_ALLOC309589 ! Node: MVBITS310613 ! Node: NEAREST311672 ! Node: NEW_LINE312795 ! Node: NINT313566 ! Node: NOT314834 ! Node: NULL315417 ! Node: OR316315 ! Node: PACK317593 ! Node: PERROR319585 ! Node: PRECISION320207 ! Node: PRESENT321033 ! Node: PRODUCT322139 ! Node: RADIX323664 ! Node: RAN324441 ! Node: RAND324897 ! Node: RANDOM_NUMBER326232 ! Node: RANDOM_SEED327950 ! Node: RANGE329833 ! Node: REAL330457 ! Node: RENAME331899 ! Node: REPEAT332918 ! Node: RESHAPE333644 ! Node: RRSPACING335113 ! Node: RSHIFT335806 ! Node: SCALE336768 ! Node: SCAN337542 ! Node: SECNDS339092 ! Node: SECOND340180 ! Node: SELECTED_CHAR_KIND341056 ! Node: SELECTED_INT_KIND342053 ! Node: SELECTED_REAL_KIND343228 ! Node: SET_EXPONENT345167 ! Node: SHAPE346163 ! Node: SIGN347276 ! Node: SIGNAL348359 ! Node: SIN349856 ! Node: SINH350898 ! Node: SIZE351710 ! Node: SIZEOF353018 ! Node: SLEEP354312 ! Node: SNGL354869 ! Node: SPACING355540 ! Node: SPREAD356552 ! Node: SQRT357697 ! Node: SRAND358936 ! Node: STAT360104 ! Node: SUM363216 ! Node: SYMLNK364685 ! Node: SYSTEM365817 ! Node: SYSTEM_CLOCK366765 ! Node: TAN368109 ! Node: TANH368945 ! Node: TIME369812 ! Node: TIME8370916 ! Node: TINY372053 ! Node: TRAILZ372653 ! Node: TRANSFER373438 ! Node: TRANSPOSE375472 ! Node: TRIM376159 ! Node: TTYNAM377016 ! Node: UBOUND377931 ! Node: UMASK379300 ! Node: UNLINK379855 ! Node: UNPACK380832 ! Node: VERIFY382120 ! Node: XOR383836 ! Node: Intrinsic Modules385144 ! Node: Contributing390935 ! Node: Contributors391787 ! Node: Projects393410 ! Node: Proposed Extensions394213 ! Node: Copying396264 ! Node: GNU Free Documentation License433828 ! Node: Funding456240 ! Node: Option Index458765 ! Node: Keyword Index470647  End Tag Table diff -Nrcpad gcc-4.4.0/gcc/fortran/interface.c gcc-4.4.1/gcc/fortran/interface.c *** gcc-4.4.0/gcc/fortran/interface.c Thu Feb 26 18:43:50 2009 --- gcc-4.4.1/gcc/fortran/interface.c Mon Jun 29 16:44:49 2009 *************** gfc_symbol * *** 2502,2507 **** --- 2502,2508 ---- gfc_search_interface (gfc_interface *intr, int sub_flag, gfc_actual_arglist **ap) { + gfc_symbol *elem_sym = NULL; for (; intr; intr = intr->next) { if (sub_flag && intr->sym->attr.function) *************** gfc_search_interface (gfc_interface *int *** 2510,2519 **** continue; if (gfc_arglist_matches_symbol (ap, intr->sym)) ! return intr->sym; } ! return NULL; } --- 2511,2529 ---- continue; if (gfc_arglist_matches_symbol (ap, intr->sym)) ! { ! /* Satisfy 12.4.4.1 such that an elemental match has lower ! weight than a non-elemental match. */ ! if (intr->sym->attr.elemental) ! { ! elem_sym = intr->sym; ! continue; ! } ! return intr->sym; ! } } ! return elem_sym ? elem_sym : NULL; } diff -Nrcpad gcc-4.4.0/gcc/fortran/module.c gcc-4.4.1/gcc/fortran/module.c *** gcc-4.4.0/gcc/fortran/module.c Fri Feb 27 07:45:47 2009 --- gcc-4.4.1/gcc/fortran/module.c Fri May 22 12:54:23 2009 *************** read_md5_from_module_file (const char * *** 4738,4744 **** if ((file = fopen (filename, "r")) == NULL) return -1; ! /* Read two lines. */ if (fgets (buf, sizeof (buf) - 1, file) == NULL) { fclose (file); --- 4738,4744 ---- if ((file = fopen (filename, "r")) == NULL) return -1; ! /* Read the first line. */ if (fgets (buf, sizeof (buf) - 1, file) == NULL) { fclose (file); *************** read_md5_from_module_file (const char * *** 4748,4755 **** /* The file also needs to be overwritten if the version number changed. */ n = strlen ("GFORTRAN module version '" MOD_VERSION "' created"); if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0) ! return -1; if (fgets (buf, sizeof (buf) - 1, file) == NULL) { fclose (file); --- 4748,4759 ---- /* The file also needs to be overwritten if the version number changed. */ n = strlen ("GFORTRAN module version '" MOD_VERSION "' created"); if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0) ! { ! fclose (file); ! return -1; ! } + /* Read a second line. */ if (fgets (buf, sizeof (buf) - 1, file) == NULL) { fclose (file); diff -Nrcpad gcc-4.4.0/gcc/fortran/resolve.c gcc-4.4.1/gcc/fortran/resolve.c *** gcc-4.4.0/gcc/fortran/resolve.c Fri Apr 3 20:56:54 2009 --- gcc-4.4.1/gcc/fortran/resolve.c Sat Jun 20 09:21:06 2009 *************** gfc_is_formal_arg (void) *** 82,87 **** --- 82,99 ---- return formal_arg_flag; } + /* Is the symbol host associated? */ + static bool + is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) + { + for (ns = ns->parent; ns; ns = ns->parent) + { + if (sym->ns == ns) + return true; + } + + return false; + } /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is an ABSTRACT derived-type. If where is not NULL, an error message with that *************** resolve_fl_derived (gfc_symbol *sym) *** 8715,8727 **** if (c->ts.type == BT_DERIVED && sym->component_access != ACCESS_PRIVATE && gfc_check_access (sym->attr.access, sym->ns->default_access) && !c->ts.derived->attr.use_assoc && !gfc_check_access (c->ts.derived->attr.access, c->ts.derived->ns->default_access)) { ! gfc_error ("The component '%s' is a PRIVATE type and cannot be " ! "a component of '%s', which is PUBLIC at %L", ! c->name, sym->name, &sym->declared_at); return FAILURE; } --- 8727,8741 ---- if (c->ts.type == BT_DERIVED && sym->component_access != ACCESS_PRIVATE && gfc_check_access (sym->attr.access, sym->ns->default_access) + && !is_sym_host_assoc (c->ts.derived, sym->ns) && !c->ts.derived->attr.use_assoc && !gfc_check_access (c->ts.derived->attr.access, c->ts.derived->ns->default_access)) { ! gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' " ! "is a PRIVATE type and cannot be a component of " ! "'%s', which is PUBLIC at %L", c->name, ! sym->name, &sym->declared_at); return FAILURE; } *************** resolve_fl_namelist (gfc_symbol *sym) *** 8803,8811 **** for (nl = sym->namelist; nl; nl = nl->next) { if (!nl->sym->attr.use_assoc ! && !(sym->ns->parent == nl->sym->ns) ! && !(sym->ns->parent ! && sym->ns->parent->parent == nl->sym->ns) && !gfc_check_access(nl->sym->attr.access, nl->sym->ns->default_access)) { --- 8817,8823 ---- for (nl = sym->namelist; nl; nl = nl->next) { if (!nl->sym->attr.use_assoc ! && !is_sym_host_assoc (nl->sym, sym->ns) && !gfc_check_access(nl->sym->attr.access, nl->sym->ns->default_access)) { *************** resolve_fl_namelist (gfc_symbol *sym) *** 8827,8833 **** /* Types with private components that are defined in the same module. */ if (nl->sym->ts.type == BT_DERIVED ! && !(sym->ns->parent == nl->sym->ts.derived->ns) && !gfc_check_access (nl->sym->ts.derived->attr.private_comp ? ACCESS_PRIVATE : ACCESS_UNKNOWN, nl->sym->ns->default_access)) --- 8839,8845 ---- /* Types with private components that are defined in the same module. */ if (nl->sym->ts.type == BT_DERIVED ! && !is_sym_host_assoc (nl->sym->ts.derived, sym->ns) && !gfc_check_access (nl->sym->ts.derived->attr.private_comp ? ACCESS_PRIVATE : ACCESS_UNKNOWN, nl->sym->ns->default_access)) *************** values; *** 9430,9438 **** static gfc_try next_data_value (void) { - while (mpz_cmp_ui (values.left, 0) == 0) { if (values.vnode->next == NULL) return FAILURE; --- 9442,9453 ---- static gfc_try next_data_value (void) { while (mpz_cmp_ui (values.left, 0) == 0) { + if (!gfc_is_constant_expr (values.vnode->expr)) + gfc_error ("non-constant DATA value at %L", + &values.vnode->expr->where); + if (values.vnode->next == NULL) return FAILURE; diff -Nrcpad gcc-4.4.0/gcc/fortran/simplify.c gcc-4.4.1/gcc/fortran/simplify.c *** gcc-4.4.0/gcc/fortran/simplify.c Fri Mar 6 09:06:51 2009 --- gcc-4.4.1/gcc/fortran/simplify.c Wed Jun 3 19:39:09 2009 *************** gfc_simplify_leadz (gfc_expr *e) *** 2410,2419 **** bs = gfc_integer_kinds[i].bit_size; if (mpz_cmp_si (e->value.integer, 0) == 0) lz = bs; else lz = bs - mpz_sizeinbase (e->value.integer, 2); ! result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where); mpz_set_ui (result->value.integer, lz); return result; --- 2410,2422 ---- bs = gfc_integer_kinds[i].bit_size; if (mpz_cmp_si (e->value.integer, 0) == 0) lz = bs; + else if (mpz_cmp_si (e->value.integer, 0) < 0) + lz = 0; else lz = bs - mpz_sizeinbase (e->value.integer, 2); ! result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, ! &e->where); mpz_set_ui (result->value.integer, lz); return result; diff -Nrcpad gcc-4.4.0/gcc/fortran/trans-array.c gcc-4.4.1/gcc/fortran/trans-array.c *** gcc-4.4.0/gcc/fortran/trans-array.c Thu Feb 26 06:23:42 2009 --- gcc-4.4.1/gcc/fortran/trans-array.c Sun Jul 5 19:06:05 2009 *************** gfc_trans_array_constructor_value (stmtb *** 1246,1255 **** gfc_init_se (&se, NULL); gfc_conv_constant (&se, p->expr); /* For constant character array constructors we build an array of pointers. */ ! if (p->expr->ts.type == BT_CHARACTER ! && POINTER_TYPE_P (type)) se.expr = gfc_build_addr_expr (gfc_get_pchar_type (p->expr->ts.kind), se.expr); --- 1246,1256 ---- gfc_init_se (&se, NULL); gfc_conv_constant (&se, p->expr); + if (c->expr->ts.type != BT_CHARACTER) + se.expr = fold_convert (type, se.expr); /* For constant character array constructors we build an array of pointers. */ ! else if (POINTER_TYPE_P (type)) se.expr = gfc_build_addr_expr (gfc_get_pchar_type (p->expr->ts.kind), se.expr); *************** gfc_build_constant_array_constructor (gf *** 1618,1624 **** { gfc_init_se (&se, NULL); gfc_conv_constant (&se, c->expr); ! if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type)) se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), se.expr); list = tree_cons (build_int_cst (gfc_array_index_type, nelem), --- 1619,1627 ---- { gfc_init_se (&se, NULL); gfc_conv_constant (&se, c->expr); ! if (c->expr->ts.type != BT_CHARACTER) ! se.expr = fold_convert (type, se.expr); ! else if (POINTER_TYPE_P (type)) se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), se.expr); list = tree_cons (build_int_cst (gfc_array_index_type, nelem), *************** gfc_conv_expr_descriptor (gfc_se * se, g *** 4819,4825 **** else if (se->direct_byref) full = 0; else ! full = gfc_full_array_ref_p (info->ref); if (full) { --- 4822,4828 ---- else if (se->direct_byref) full = 0; else ! full = gfc_full_array_ref_p (info->ref, NULL); if (full) { diff -Nrcpad gcc-4.4.0/gcc/fortran/trans-decl.c gcc-4.4.1/gcc/fortran/trans-decl.c *** gcc-4.4.0/gcc/fortran/trans-decl.c Wed Apr 8 14:03:33 2009 --- gcc-4.4.1/gcc/fortran/trans-decl.c Wed Jun 3 19:39:09 2009 *************** tree gfor_fndecl_convert_char4_to_char1; *** 141,146 **** --- 141,148 ---- tree gfor_fndecl_size0; tree gfor_fndecl_size1; tree gfor_fndecl_iargc; + tree gfor_fndecl_clz128; + tree gfor_fndecl_ctz128; /* Intrinsic functions implemented in Fortran. */ tree gfor_fndecl_sc_kind; *************** gfc_build_intrinsic_function_decls (void *** 2488,2493 **** --- 2490,2508 ---- gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0); + + if (gfc_type_for_size (128, true)) + { + tree uint128 = gfc_type_for_size (128, true); + + gfor_fndecl_clz128 = + gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")), + integer_type_node, 1, uint128); + + gfor_fndecl_ctz128 = + gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")), + integer_type_node, 1, uint128); + } } diff -Nrcpad gcc-4.4.0/gcc/fortran/trans-expr.c gcc-4.4.1/gcc/fortran/trans-expr.c *** gcc-4.4.0/gcc/fortran/trans-expr.c Fri Feb 20 15:20:38 2009 --- gcc-4.4.1/gcc/fortran/trans-expr.c Thu Jul 9 19:28:20 2009 *************** gfc_conv_function_val (gfc_se * se, gfc_ *** 1526,1573 **** } - /* Translate the call for an elemental subroutine call used in an operator - assignment. This is a simplified version of gfc_conv_function_call. */ - - tree - gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym) - { - tree args; - tree tmp; - gfc_se se; - stmtblock_t block; - - /* Only elemental subroutines with two arguments. */ - gcc_assert (sym->attr.elemental && sym->attr.subroutine); - gcc_assert (sym->formal->next->next == NULL); - - gfc_init_block (&block); - - gfc_add_block_to_block (&block, &lse->pre); - gfc_add_block_to_block (&block, &rse->pre); - - /* Build the argument list for the call, including hidden string lengths. */ - args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr)); - args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr)); - if (lse->string_length != NULL_TREE) - args = gfc_chainon_list (args, lse->string_length); - if (rse->string_length != NULL_TREE) - args = gfc_chainon_list (args, rse->string_length); - - /* Build the function call. */ - gfc_init_se (&se, NULL); - gfc_conv_function_val (&se, sym); - tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr))); - tmp = build_call_list (tmp, se.expr, args); - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &lse->post); - gfc_add_block_to_block (&block, &rse->post); - - return gfc_finish_block (&block); - } - - /* Initialize MAPPING. */ void --- 1526,1531 ---- *************** gfc_conv_function_call (gfc_se * se, gfc *** 2765,2770 **** --- 2723,2729 ---- dealt with in trans-array.c(gfc_conv_array_parameter). */ if (e && e->ts.type == BT_DERIVED && e->ts.derived->attr.alloc_comp + && !(e->symtree && e->symtree->n.sym->attr.pointer) && (e->expr_type != EXPR_VARIABLE && !e->rank)) { int parm_rank; *************** gfc_conv_function_call (gfc_se * se, gfc *** 2782,2788 **** --- 2741,2758 ---- break; } + if (e->expr_type == EXPR_OP + && e->value.op.op == INTRINSIC_PARENTHESES + && e->value.op.op1->expr_type == EXPR_VARIABLE) + { + tree local_tmp; + local_tmp = gfc_evaluate_now (tmp, &se->pre); + local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank); + gfc_add_expr_to_block (&se->post, local_tmp); + } + tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank); + gfc_add_expr_to_block (&se->post, tmp); } *************** gfc_trans_arrayfunc_assign (gfc_expr * e *** 4286,4291 **** --- 4256,4262 ---- gfc_ss *ss; gfc_ref * ref; bool seen_array_ref; + bool c = false; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) *************** gfc_trans_arrayfunc_assign (gfc_expr * e *** 4296,4301 **** --- 4267,4276 ---- && expr2->value.function.esym->attr.elemental) return NULL; + /* Fail if rhs is not FULL or a contiguous section. */ + if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c)) + return NULL; + /* Fail if EXPR1 can't be expressed as a descriptor. */ if (gfc_ref_needs_temporary_p (expr1->ref)) return NULL; *************** gfc_trans_zero_assign (gfc_expr * expr) *** 4430,4440 **** len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, fold_convert (gfc_array_index_type, tmp)); ! /* Convert arguments to the correct types. */ if (!POINTER_TYPE_P (TREE_TYPE (dest))) ! dest = gfc_build_addr_expr (pvoid_type_node, dest); ! else ! dest = fold_convert (pvoid_type_node, dest); len = fold_convert (size_type_node, len); /* Construct call to __builtin_memset. */ --- 4405,4418 ---- len = fold_build2 (MULT_EXPR, gfc_array_index_type, len, fold_convert (gfc_array_index_type, tmp)); ! /* If we are zeroing a local array avoid taking its address by emitting ! a = {} instead. */ if (!POINTER_TYPE_P (TREE_TYPE (dest))) ! return build2 (MODIFY_EXPR, void_type_node, ! dest, build_constructor (TREE_TYPE (dest), NULL)); ! ! /* Convert arguments to the correct types. */ ! dest = fold_convert (pvoid_type_node, dest); len = fold_convert (size_type_node, len); /* Construct call to __builtin_memset. */ *************** copyable_array_p (gfc_expr * expr) *** 4749,4755 **** if (expr->rank < 1 || !expr->ref || expr->ref->next) return false; ! if (!gfc_full_array_ref_p (expr->ref)) return false; /* Next check that it's of a simple enough type. */ --- 4727,4733 ---- if (expr->rank < 1 || !expr->ref || expr->ref->next) return false; ! if (!gfc_full_array_ref_p (expr->ref, NULL)) return false; /* Next check that it's of a simple enough type. */ diff -Nrcpad gcc-4.4.0/gcc/fortran/trans-intrinsic.c gcc-4.4.1/gcc/fortran/trans-intrinsic.c *** gcc-4.4.0/gcc/fortran/trans-intrinsic.c Fri Feb 20 15:20:38 2009 --- gcc-4.4.1/gcc/fortran/trans-intrinsic.c Sat Jul 4 17:22:46 2009 *************** gfc_conv_intrinsic_minmaxloc (gfc_se * s *** 2181,2192 **** possible value is HUGE in both cases. */ if (op == GT_EXPR) tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); - gfc_add_modify (&se->pre, limit, tmp); - if (op == GT_EXPR && expr->ts.type == BT_INTEGER) tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp, build_int_cst (type, 1)); /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, arrayss); --- 2181,2192 ---- possible value is HUGE in both cases. */ if (op == GT_EXPR) tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); if (op == GT_EXPR && expr->ts.type == BT_INTEGER) tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp, build_int_cst (type, 1)); + gfc_add_modify (&se->pre, limit, tmp); + /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, arrayss); *************** gfc_conv_intrinsic_leadz (gfc_se * se, g *** 2707,2759 **** tree leadz; tree bit_size; tree tmp; ! int arg_kind; ! int i, n, s; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); /* Which variant of __builtin_clz* should we call? */ ! arg_kind = expr->value.function.actual->expr->ts.kind; ! i = gfc_validate_kind (BT_INTEGER, arg_kind, false); ! switch (arg_kind) { ! case 1: ! case 2: ! case 4: ! arg_type = unsigned_type_node; ! n = BUILT_IN_CLZ; ! break; ! ! case 8: ! arg_type = long_unsigned_type_node; ! n = BUILT_IN_CLZL; ! break; ! ! case 16: ! arg_type = long_long_unsigned_type_node; ! n = BUILT_IN_CLZLL; ! break; ! ! default: ! gcc_unreachable (); } ! /* Convert the actual argument to the proper argument type for the built-in function. But the return type is of the default INTEGER kind. */ arg = fold_convert (arg_type, arg); result_type = gfc_get_int_type (gfc_default_integer_kind); /* Compute LEADZ for the case i .ne. 0. */ ! s = TYPE_PRECISION (arg_type) - gfc_integer_kinds[i].bit_size; ! tmp = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg)); leadz = fold_build2 (MINUS_EXPR, result_type, tmp, build_int_cst (result_type, s)); /* Build BIT_SIZE. */ ! bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size); - /* ??? For some combinations of targets and integer kinds, the condition - can be avoided if CLZ_DEFINED_VALUE_AT_ZERO is used. Later. */ cond = fold_build2 (EQ_EXPR, boolean_type_node, arg, build_int_cst (arg_type, 0)); se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz); --- 2707,2757 ---- tree leadz; tree bit_size; tree tmp; ! tree func; ! int s, argsize; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + argsize = TYPE_PRECISION (TREE_TYPE (arg)); /* Which variant of __builtin_clz* should we call? */ ! if (argsize <= INT_TYPE_SIZE) { ! arg_type = unsigned_type_node; ! func = built_in_decls[BUILT_IN_CLZ]; ! } ! else if (argsize <= LONG_TYPE_SIZE) ! { ! arg_type = long_unsigned_type_node; ! func = built_in_decls[BUILT_IN_CLZL]; ! } ! else if (argsize <= LONG_LONG_TYPE_SIZE) ! { ! arg_type = long_long_unsigned_type_node; ! func = built_in_decls[BUILT_IN_CLZLL]; ! } ! else ! { ! gcc_assert (argsize == 128); ! arg_type = gfc_build_uint_type (argsize); ! func = gfor_fndecl_clz128; } ! /* Convert the actual argument twice: first, to the unsigned type of the ! same size; then, to the proper argument type for the built-in function. But the return type is of the default INTEGER kind. */ + arg = fold_convert (gfc_build_uint_type (argsize), arg); arg = fold_convert (arg_type, arg); result_type = gfc_get_int_type (gfc_default_integer_kind); /* Compute LEADZ for the case i .ne. 0. */ ! s = TYPE_PRECISION (arg_type) - argsize; ! tmp = fold_convert (result_type, build_call_expr (func, 1, arg)); leadz = fold_build2 (MINUS_EXPR, result_type, tmp, build_int_cst (result_type, s)); /* Build BIT_SIZE. */ ! bit_size = build_int_cst (result_type, argsize); cond = fold_build2 (EQ_EXPR, boolean_type_node, arg, build_int_cst (arg_type, 0)); se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz); *************** gfc_conv_intrinsic_trailz (gfc_se * se, *** 2774,2823 **** tree result_type; tree trailz; tree bit_size; ! int arg_kind; ! int i, n; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); ! /* Which variant of __builtin_clz* should we call? */ ! arg_kind = expr->value.function.actual->expr->ts.kind; ! i = gfc_validate_kind (BT_INTEGER, arg_kind, false); ! switch (expr->ts.kind) { ! case 1: ! case 2: ! case 4: ! arg_type = unsigned_type_node; ! n = BUILT_IN_CTZ; ! break; ! ! case 8: ! arg_type = long_unsigned_type_node; ! n = BUILT_IN_CTZL; ! break; ! ! case 16: ! arg_type = long_long_unsigned_type_node; ! n = BUILT_IN_CTZLL; ! break; ! ! default: ! gcc_unreachable (); } ! /* Convert the actual argument to the proper argument type for the built-in function. But the return type is of the default INTEGER kind. */ arg = fold_convert (arg_type, arg); result_type = gfc_get_int_type (gfc_default_integer_kind); /* Compute TRAILZ for the case i .ne. 0. */ ! trailz = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg)); /* Build BIT_SIZE. */ ! bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size); - /* ??? For some combinations of targets and integer kinds, the condition - can be avoided if CTZ_DEFINED_VALUE_AT_ZERO is used. Later. */ cond = fold_build2 (EQ_EXPR, boolean_type_node, arg, build_int_cst (arg_type, 0)); se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz); --- 2772,2819 ---- tree result_type; tree trailz; tree bit_size; ! tree func; ! int argsize; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + argsize = TYPE_PRECISION (TREE_TYPE (arg)); ! /* Which variant of __builtin_ctz* should we call? */ ! if (argsize <= INT_TYPE_SIZE) { ! arg_type = unsigned_type_node; ! func = built_in_decls[BUILT_IN_CTZ]; ! } ! else if (argsize <= LONG_TYPE_SIZE) ! { ! arg_type = long_unsigned_type_node; ! func = built_in_decls[BUILT_IN_CTZL]; ! } ! else if (argsize <= LONG_LONG_TYPE_SIZE) ! { ! arg_type = long_long_unsigned_type_node; ! func = built_in_decls[BUILT_IN_CTZLL]; ! } ! else ! { ! gcc_assert (argsize == 128); ! arg_type = gfc_build_uint_type (argsize); ! func = gfor_fndecl_ctz128; } ! /* Convert the actual argument twice: first, to the unsigned type of the ! same size; then, to the proper argument type for the built-in function. But the return type is of the default INTEGER kind. */ + arg = fold_convert (gfc_build_uint_type (argsize), arg); arg = fold_convert (arg_type, arg); result_type = gfc_get_int_type (gfc_default_integer_kind); /* Compute TRAILZ for the case i .ne. 0. */ ! trailz = fold_convert (result_type, build_call_expr (func, 1, arg)); /* Build BIT_SIZE. */ ! bit_size = build_int_cst (result_type, argsize); cond = fold_build2 (EQ_EXPR, boolean_type_node, arg, build_int_cst (arg_type, 0)); se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz); *************** gfc_conv_intrinsic_fraction (gfc_se * se *** 3129,3160 **** /* NEAREST (s, dir) is translated into ! tmp = copysign (INF, dir); return nextafter (s, tmp); */ static void gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) { tree args[2], type, tmp; ! int nextafter, copysign, inf; switch (expr->ts.kind) { case 4: nextafter = BUILT_IN_NEXTAFTERF; copysign = BUILT_IN_COPYSIGNF; ! inf = BUILT_IN_INFF; break; case 8: nextafter = BUILT_IN_NEXTAFTER; copysign = BUILT_IN_COPYSIGN; ! inf = BUILT_IN_INF; break; case 10: case 16: nextafter = BUILT_IN_NEXTAFTERL; copysign = BUILT_IN_COPYSIGNL; ! inf = BUILT_IN_INFL; break; default: gcc_unreachable (); --- 3125,3156 ---- /* NEAREST (s, dir) is translated into ! tmp = copysign (HUGE_VAL, dir); return nextafter (s, tmp); */ static void gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) { tree args[2], type, tmp; ! int nextafter, copysign, huge_val; switch (expr->ts.kind) { case 4: nextafter = BUILT_IN_NEXTAFTERF; copysign = BUILT_IN_COPYSIGNF; ! huge_val = BUILT_IN_HUGE_VALF; break; case 8: nextafter = BUILT_IN_NEXTAFTER; copysign = BUILT_IN_COPYSIGN; ! huge_val = BUILT_IN_HUGE_VAL; break; case 10: case 16: nextafter = BUILT_IN_NEXTAFTERL; copysign = BUILT_IN_COPYSIGNL; ! huge_val = BUILT_IN_HUGE_VALL; break; default: gcc_unreachable (); *************** gfc_conv_intrinsic_nearest (gfc_se * se, *** 3163,3169 **** type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); tmp = build_call_expr (built_in_decls[copysign], 2, ! build_call_expr (built_in_decls[inf], 0), fold_convert (type, args[1])); se->expr = build_call_expr (built_in_decls[nextafter], 2, fold_convert (type, args[0]), tmp); --- 3159,3165 ---- type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); tmp = build_call_expr (built_in_decls[copysign], 2, ! build_call_expr (built_in_decls[huge_val], 0), fold_convert (type, args[1])); se->expr = build_call_expr (built_in_decls[nextafter], 2, fold_convert (type, args[0]), tmp); diff -Nrcpad gcc-4.4.0/gcc/fortran/trans-io.c gcc-4.4.1/gcc/fortran/trans-io.c *** gcc-4.4.0/gcc/fortran/trans-io.c Sat Nov 22 08:10:41 2008 --- gcc-4.4.1/gcc/fortran/trans-io.c Sat Jul 4 03:07:12 2009 *************** set_parameter_value (stmtblock_t *block, *** 471,477 **** gfc_conv_expr_val (&se, e); /* If we're storing a UNIT number, we need to check it first. */ ! if (type == IOPARM_common_unit && e->ts.kind != 4) { tree cond, max; int i; --- 471,477 ---- gfc_conv_expr_val (&se, e); /* If we're storing a UNIT number, we need to check it first. */ ! if (type == IOPARM_common_unit && e->ts.kind > 4) { tree cond, max; int i; diff -Nrcpad gcc-4.4.0/gcc/fortran/trans-stmt.c gcc-4.4.1/gcc/fortran/trans-stmt.c *** gcc-4.4.0/gcc/fortran/trans-stmt.c Tue Jan 27 18:07:54 2009 --- gcc-4.4.1/gcc/fortran/trans-stmt.c Sun May 10 15:34:55 2009 *************** gfc_conv_elemental_dependencies (gfc_se *** 270,278 **** gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e)); gfc_add_block_to_block (&se->pre, &parmse.pre); ! /* If we've got INTENT(INOUT), initialize the array temporary with ! a copy of the values. */ ! if (fsym->attr.intent == INTENT_INOUT) initial = parmse.expr; else initial = NULL_TREE; --- 270,280 ---- gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e)); gfc_add_block_to_block (&se->pre, &parmse.pre); ! /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT), ! initialize the array temporary with a copy of the values. */ ! if (fsym->attr.intent == INTENT_INOUT ! || (fsym->ts.type ==BT_DERIVED ! && fsym->attr.intent == INTENT_OUT)) initial = parmse.expr; else initial = NULL_TREE; *************** gfc_conv_elemental_dependencies (gfc_se *** 332,343 **** /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree ! gfc_trans_call (gfc_code * code, bool dependency_check) { gfc_se se; gfc_ss * ss; int has_alternate_specifier; gfc_dep_check check_variable; /* A CALL starts a new block because the actual arguments may have to be evaluated first. */ --- 334,349 ---- /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree ! gfc_trans_call (gfc_code * code, bool dependency_check, ! tree mask, tree count1, bool invert) { gfc_se se; gfc_ss * ss; int has_alternate_specifier; gfc_dep_check check_variable; + tree index = NULL_TREE; + tree maskexpr = NULL_TREE; + tree tmp; /* A CALL starts a new block because the actual arguments may have to be evaluated first. */ *************** gfc_trans_call (gfc_code * code, bool de *** 429,438 **** gfc_start_scalarized_body (&loop, &body); gfc_init_block (&block); /* Add the subroutine call to the block. */ ! gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual, ! NULL_TREE); ! gfc_add_expr_to_block (&loopse.pre, loopse.expr); gfc_add_block_to_block (&block, &loopse.pre); gfc_add_block_to_block (&block, &loopse.post); --- 435,465 ---- gfc_start_scalarized_body (&loop, &body); gfc_init_block (&block); + if (mask && count1) + { + /* Form the mask expression according to the mask. */ + index = count1; + maskexpr = gfc_build_array_ref (mask, index, NULL); + if (invert) + maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), + maskexpr); + } + /* Add the subroutine call to the block. */ ! gfc_conv_function_call (&loopse, code->resolved_sym, ! code->ext.actual, NULL_TREE); ! ! if (mask && count1) ! { ! tmp = build3_v (COND_EXPR, maskexpr, loopse.expr, ! build_empty_stmt ()); ! gfc_add_expr_to_block (&loopse.pre, tmp); ! tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ! count1, gfc_index_one_node); ! gfc_add_modify (&loopse.pre, count1, tmp); ! } ! else ! gfc_add_expr_to_block (&loopse.pre, loopse.expr); gfc_add_block_to_block (&block, &loopse.pre); gfc_add_block_to_block (&block, &loopse.post); *************** gfc_trans_forall_1 (gfc_code * code, for *** 2981,2987 **** /* Explicit subroutine calls are prevented by the frontend but interface assignments can legitimately produce them. */ case EXEC_ASSIGN_CALL: ! assign = gfc_trans_call (c, true); tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1); gfc_add_expr_to_block (&block, tmp); break; --- 3008,3014 ---- /* Explicit subroutine calls are prevented by the frontend but interface assignments can legitimately produce them. */ case EXEC_ASSIGN_CALL: ! assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false); tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1); gfc_add_expr_to_block (&block, tmp); break; *************** static tree *** 3176,3182 **** gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask, bool invert, tree count1, tree count2, ! gfc_symbol *sym) { gfc_se lse; gfc_se rse; --- 3203,3209 ---- gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask, bool invert, tree count1, tree count2, ! gfc_code *cnext) { gfc_se lse; gfc_se rse; *************** gfc_trans_where_assign (gfc_expr *expr1, *** 3190,3195 **** --- 3217,3226 ---- stmtblock_t body; tree index, maskexpr; + /* A defined assignment. */ + if (cnext && cnext->resolved_sym) + return gfc_trans_call (cnext, true, mask, count1, invert); + #if 0 /* TODO: handle this special case. Special case a single function returning an array. */ *************** gfc_trans_where_assign (gfc_expr *expr1, *** 3291,3301 **** maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr); /* Use the scalar assignment as is. */ ! if (sym == NULL) ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, ! loop.temp_ss != NULL, false); ! else ! tmp = gfc_conv_operator_assign (&lse, &rse, sym); tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); --- 3322,3329 ---- maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr); /* Use the scalar assignment as is. */ ! tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, ! loop.temp_ss != NULL, false); tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); *************** gfc_trans_where_2 (gfc_code * code, tree *** 3562,3568 **** tmp = gfc_trans_where_assign (expr1, expr2, cmask, invert, count1, count2, ! cnext->resolved_sym); tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); --- 3590,3596 ---- tmp = gfc_trans_where_assign (expr1, expr2, cmask, invert, count1, count2, ! cnext); tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); *************** gfc_trans_where_2 (gfc_code * code, tree *** 3580,3586 **** tmp = gfc_trans_where_assign (expr1, expr2, cmask, invert, count1, count2, ! cnext->resolved_sym); gfc_add_expr_to_block (block, tmp); } --- 3608,3614 ---- tmp = gfc_trans_where_assign (expr1, expr2, cmask, invert, count1, count2, ! cnext); gfc_add_expr_to_block (block, tmp); } diff -Nrcpad gcc-4.4.0/gcc/fortran/trans-stmt.h gcc-4.4.1/gcc/fortran/trans-stmt.h *** gcc-4.4.0/gcc/fortran/trans-stmt.h Sat Apr 5 22:23:27 2008 --- gcc-4.4.1/gcc/fortran/trans-stmt.h Sun May 10 15:34:55 2009 *************** tree gfc_trans_goto (gfc_code *); *** 39,45 **** tree gfc_trans_entry (gfc_code *); tree gfc_trans_pause (gfc_code *); tree gfc_trans_stop (gfc_code *); ! tree gfc_trans_call (gfc_code *, bool); tree gfc_trans_return (gfc_code *); tree gfc_trans_if (gfc_code *); tree gfc_trans_arithmetic_if (gfc_code *); --- 39,45 ---- tree gfc_trans_entry (gfc_code *); tree gfc_trans_pause (gfc_code *); tree gfc_trans_stop (gfc_code *); ! tree gfc_trans_call (gfc_code *, bool, tree, tree, bool); tree gfc_trans_return (gfc_code *); tree gfc_trans_if (gfc_code *); tree gfc_trans_arithmetic_if (gfc_code *); diff -Nrcpad gcc-4.4.0/gcc/fortran/trans-types.c gcc-4.4.1/gcc/fortran/trans-types.c *** gcc-4.4.0/gcc/fortran/trans-types.c Mon Mar 30 14:53:17 2009 --- gcc-4.4.1/gcc/fortran/trans-types.c Wed Jun 3 19:39:09 2009 *************** gfc_build_int_type (gfc_integer_info *in *** 595,601 **** return make_signed_type (mode_precision); } ! static tree gfc_build_uint_type (int size) { if (size == CHAR_TYPE_SIZE) --- 595,601 ---- return make_signed_type (mode_precision); } ! tree gfc_build_uint_type (int size) { if (size == CHAR_TYPE_SIZE) diff -Nrcpad gcc-4.4.0/gcc/fortran/trans-types.h gcc-4.4.1/gcc/fortran/trans-types.h *** gcc-4.4.0/gcc/fortran/trans-types.h Sun May 18 22:45:05 2008 --- gcc-4.4.1/gcc/fortran/trans-types.h Wed Jun 3 19:39:09 2009 *************** tree gfc_get_function_type (gfc_symbol * *** 68,73 **** --- 68,74 ---- tree gfc_type_for_size (unsigned, int); tree gfc_type_for_mode (enum machine_mode, int); + tree gfc_build_uint_type (int); tree gfc_get_element_type (tree); tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int, diff -Nrcpad gcc-4.4.0/gcc/fortran/trans.c gcc-4.4.1/gcc/fortran/trans.c *** gcc-4.4.0/gcc/fortran/trans.c Sat Nov 1 13:26:19 2008 --- gcc-4.4.1/gcc/fortran/trans.c Sun May 10 15:34:55 2009 *************** gfc_trans_code (gfc_code * code) *** 1109,1120 **** if (code->resolved_isym && code->resolved_isym->id == GFC_ISYM_MVBITS) is_mvbits = true; ! res = gfc_trans_call (code, is_mvbits); } break; case EXEC_ASSIGN_CALL: ! res = gfc_trans_call (code, true); break; case EXEC_RETURN: --- 1109,1122 ---- if (code->resolved_isym && code->resolved_isym->id == GFC_ISYM_MVBITS) is_mvbits = true; ! res = gfc_trans_call (code, is_mvbits, NULL_TREE, ! NULL_TREE, false); } break; case EXEC_ASSIGN_CALL: ! res = gfc_trans_call (code, true, NULL_TREE, ! NULL_TREE, false); break; case EXEC_RETURN: diff -Nrcpad gcc-4.4.0/gcc/fortran/trans.h gcc-4.4.1/gcc/fortran/trans.h *** gcc-4.4.0/gcc/fortran/trans.h Thu Dec 18 10:05:54 2008 --- gcc-4.4.1/gcc/fortran/trans.h Wed Jun 3 19:39:09 2009 *************** void gfc_conv_intrinsic_function (gfc_se *** 310,318 **** /* Does an intrinsic map directly to an external library call. */ int gfc_is_intrinsic_libcall (gfc_expr *); - /* Used to call the elemental subroutines used in operator assignments. */ - tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *); - /* Also used to CALL subroutines. */ int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *, tree); --- 310,315 ---- *************** extern GTY(()) tree gfor_fndecl_convert_ *** 594,599 **** --- 591,598 ---- extern GTY(()) tree gfor_fndecl_size0; extern GTY(()) tree gfor_fndecl_size1; extern GTY(()) tree gfor_fndecl_iargc; + extern GTY(()) tree gfor_fndecl_clz128; + extern GTY(()) tree gfor_fndecl_ctz128; /* Implemented in Fortran. */ extern GTY(()) tree gfor_fndecl_sc_kind; diff -Nrcpad gcc-4.4.0/libgfortran/ChangeLog gcc-4.4.1/libgfortran/ChangeLog *** gcc-4.4.0/libgfortran/ChangeLog Tue Apr 21 08:47:03 2009 --- gcc-4.4.1/libgfortran/ChangeLog Wed Jul 22 07:31:09 2009 *************** *** 1,3 **** --- 1,376 ---- + 2009-07-22 Release Manager + + * GCC 4.4.1 released. + + 2009-07-19 Janne Blomqvist + Jerry DeLisle + + PR libfortran/40714 + * io/transfer.c (finalize_transfer): Set current_record to 0 + before returning in case of error. + * io/open.c: Fix spelling in comment. + + 2009-06-29 Jerry DeLisle + + PR libfortran/40576 + * io/transfer.c (sset): Adjust exit condition for loop. + + 2009-06-11 Jerry DeLisle + + PR libfortran/40330 + * io/io.h: Revert format caching. + * io/unit.c: Likewise. + * io/transfer.c: Likewise. + * io/format.c: Likewise. + + 2009-06-09 Janne Blomqvist + + PR libfortran/40330 + * io/format.c (free_format_hash_table): Also free and nullify hash + key. + (save_parsed_format): Copy string rather than pointer copy. + + 2009-06-08 Jerry DeLisle + + PR libfortran/40334 + * io/list_read.c (list_formatted_read_scalar): Set the end file + conditions after a return from EOF error. + + 2009-06-03 Francois-Xavier Coudert + + PR fortran/40019 + * intrinsics/bit_intrinsics.c: New file. + * gfortran.map (GFORTRAN_1.2): New list. + * Makefile.am: Add intrinsics/bit_intrinsics.c. + * Makefile.in: Regenerate. + + 2009-05-23 Jerry DeLisle + + Backport from mainline: + PR libfortran/37754 + * io/write_float.def: Simplify format calculation. + + 2009-05-23 Francois-Xavier Coudert + + Backport from mainline: + PR fortran/22423 + * io/transfer.c (read_block_direct): Avoid warning. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + PR libfortran/39667 + * io/file_pos.c (st_rewind): Don't truncate or flush. + * io/intrinsics.c (fgetc): Flush if switching mode. + (fputc): Likewise. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + PR libfortran/39782 + * io/transfer.c (data_transfer_init): Don't flush before seek. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + * io/io.h (is_preconnected): Remove prototype. + * io/unix.c (is_preconnected): Remove function. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + PR libfortran/38668 + * io/transfer.c (finalize_transfer): Don't flush for advance='no'. + + 2009-05-23 Danny Smith + + Backport from mainline: + * io/write.c (itoa) : Rename back to gfc_itoa. + (write_i): Adjust call to write_decimal. + (write_integer): Use gfc_itoa. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + * io/io.h (move_pos_offset): Remove prototype. + * io/transfer.c (formatted_transfer_scalar_read): Use sseek + instead of move_pos_offset. + * io/unix.c (move_pos_offset): Remove. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + PR libfortran/39665 libfortran/39702 libfortran/39709 + * io/io.h (st_parameter_dt): Revert aligned attribute from u.p.value. + * io/list_read.c (read_complex): Read directly into user pointer. + (read_real): Likewise. + (list_formatted_read_scalar): Update read_complex and read_real calls. + (nml_read_obj): Read directly into user pointer. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + PR libfortran/39665 + * io/io.h (st_parameter_dt): Add aligned attribute to u.p.value. + * io/read.c (convert_real): Add note about alignment requirements. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + * io/open.c (already_open): Test for POSIX close return value. + * io/unit.c (close_unit_1): Likewise. + * io/unix.c (raw_close): Return 0 for success for preconnected units. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + * runtime/error.c (gfc_itoa): Move to io/write.c + (xtoa): Rename to gfc_xtoa. + * runtime/backtrace.c (show_backtrace): Call gfc_xtoa. + * libgfortran.h (gfc_itoa): Remove prototype. + (xtoa): Rename prototype to gfc_xtoa. + * io/list_read.c (nml_read_obj): Use size_t for string length. + * io/transfer.c (read_block_direct): Change nbytes arg from + pointer to value. + (unformatted_read): Minor cleanup, call read_block_directly properly. + (skip_record): Use ssize_t. + (next_record_w_unf): Avoid stell() call by calling sseek with SEEK_CUR. + (iolength_transfer): Make sure to multiply before cast. + * io/intrinsics.c (fgetc): Remove unnecessary variable. + * io/format.c (format_hash): Use gfc_charlen_type. + * io/write.c (itoa): Move from runtime/error.c:gfc_itoa, rename, + make static. + (write_i): Call with pointer to itoa. + (write_z): Call with pointer to gfc_xtoa. + (write_integer): Pointer to itoa. + (nml_write_obj): Type cleanup, don't call strlen in loop. + + 2009-05-23 H.J. Lu + + Backport from mainline: + PR libgfortran/39664 + * io/unix.c (raw_close): Don't close STDOUT_FILENO, + STDERR_FILENO nor STDIN_FILENO. + + 2009-05-23 David Edelsohn + + Backport from mainline: + * io/io.h (struct stream): Rename truncate to trunc. + (struncate): Same. + * io/unix.c (raw_init): Rename truncate to trunc. + (buf_init): Same. + (open_internal): Same. + + 2009-05-23 Daniel Kraft + + Backport from mainline: + PR fortran/38654 + * io/read.c (read_f): Reworked to speed up floating point parsing. + (convert_real): Use pointer-casting instead of memcpy and temporaries. + + 2009-05-23 Jerry DeLisle + + Backport from mainline: + PR libfortran/37754 + * io/io.h (format_hash_entry): New structure for hash table. + (format_hash_table): The hash table itself. + (free_format_data): Revise function prototype. + (free_format_hash_table, init_format_hash, + free_format_hash): New function prototypes. + * io/unit.c (close_unit_1): Use free_format_hash_table. + * io/transfer.c (st_read_done, st_write_done): Free format data if + internal unit. + * io/format.c (free_format_hash_table): New function that frees any + memory allocated previously for cached format data. + (reset_node): New static helper function to reset the format counters + for a format node. + (reset_fnode_counters): New static function recursively calls reset_node + to traverse the fnode tree. + (format_hash): New simple hash function based on XOR, probabalistic, + tosses collisions. + (save_parsed_format): New static function to save the parsed format + data to use again. + (find_parsed_format): New static function searches the hash table + looking for a match. + (free_format_data): Revised to accept pointer to format data rather than + the dtp pointer so that the function can be used in more places. + (format_lex): Editorial. + (parse_format_list): Set flag used to determine of format data hashing + is to be used. Internal units are not persistent enough for this. + (revert): Move to ne location in file. + (parse_format): Use new functions to look for previously parsed + format strings and use them rather than re-parse. If not found, saves + the parsed format data for later use. + + 2009-05-23 Jerry DeLisle + + Backport from mainline: + PR libfortran/37754 + * io/transfer.c (formatted_transfer_scalar): Remove this function by + factoring it into two new functions, one for read and one for write, + eliminating all the conditionals for read or write mode. + (formatted transfer_scalar_read): New function. + (formatted transfer_scalar_write): New function. + (formatted_transfer): Use new functions. + + 2009-05-23 Janne Blomqvist + + Backport from mainline: + PR libfortran/25561 libfortran/37754 + * io/io.h (struct stream): Define new stream interface function + pointers, and inline functions for accessing it. + (struct fbuf): Use int instead of size_t, remove flushed element. + (mem_alloc_w): New prototype. + (mem_alloc_r): New prototype. + (stream_at_bof): Remove prototype. + (stream_at_eof): Remove prototype. + (file_position): Remove prototype. + (flush): Remove prototype. + (stream_offset): Remove prototype. + (unit_truncate): New prototype. + (read_block_form): Change to return pointer, int* argument. + (hit_eof): New prototype. + (fbuf_init): Change prototype. + (fbuf_reset): Change prototype. + (fbuf_alloc): Change prototype. + (fbuf_flush): Change prototype. + (fbuf_seek): Change prototype. + (fbuf_read): New prototype. + (fbuf_getc_refill): New prototype. + (fbuf_getc): New inline function. + * io/fbuf.c (fbuf_init): Use int, get rid of flushed. + (fbuf_debug): New function. + (fbuf_reset): Flush, and return position offset. + (fbuf_alloc): Simplify, don't flush, just realloc. + (fbuf_flush): Make usable for read mode, salvage remaining bytes. + (fbuf_seek): New whence argument. + (fbuf_read): New function. + (fbuf_getc_refill): New function. + * io/file_pos.c (formatted_backspace): Use new stream interface. + (unformatted_backspace): Likewise. + (st_backspace): Make sure format buffer is reset, use new stream + interface, use unit_truncate. + (st_endfile): Likewise. + (st_rewind): Likewise. + * io/intrinsics.c: Use new stream interface. + * io/list_read.c (push_char): Don't use u.p.scratch, use realloc + to resize. + (free_saved): Don't check u.p.scratch. + (next_char): Use new stream interface, use fbuf_getc() for external files. + (finish_list_read): flush format buffer. + (nml_query): Update to use modified interface:s + * io/open.c (test_endfile): Use new stream interface. + (edit_modes): Likewise. + (new_unit): Likewise, set bytes_left to 1 for stream files. + * io/read.c (read_l): Use new read_block_form interface. + (read_utf8): Likewise. + (read_utf8_char1): Likewise. + (read_default_char1): Likewise. + (read_utf8_char4): Likewise. + (read_default_char4): Likewise. + (read_a): Likewise. + (read_a_char4): Likewise. + (read_decimal): Likewise. + (read_radix): Likewise. + (read_f): Likewise. + * io/transfer.c (read_sf): Use fbuf_read and mem_alloc_r, remove + usage of u.p.line_buffer. + (read_block_form): Update interface to return pointer, use + fbuf_read for direct access. + (read_block_direct): Update to new stream interface. + (write_block): Use mem_alloc_w for internal I/O. + (write_buf): Update to new stream interface. + (formatted_transfer_scalar): Don't use u.p.line_buffer, use + fbuf_seek for external files. + (us_read): Update to new stream interface. + (us_write): Likewise. + (data_transfer_init): Always check if we switch modes and flush. + (skip_record): Use new stream interface, fix comparison. + (next_record_r): Check for and reset u.p.at_eof, use new stream + interface, use fbuf_getc for spacing. + (write_us_marker): Update to new stream interface, don't inline. + (next_record_w_unf): Likewise. + (sset): New function. + (next_record_w): Use new stream interface, use fbuf for printing + newline. + (next_record): Use new stream interface. + (finalize_transfer): Remove sfree call, use new stream interface. + (st_iolength_done): Don't use u.p.scratch. + (st_read): Don't check for end of file. + (st_read_done): Don't use u.p.scratch, use unit_truncate. + (hit_eof): New function. + * io/unit.c (init_units): Always init fbuf for formatted units. + (update_position): Use new stream interface. + (unit_truncate): New function. + (finish_last_advance_record): Use fbuf to print newline. + * io/unix.c: Remove unused SSIZE_MAX macro. + (BUFFER_SIZE): Make static const variable rather than macro. + (struct unix_stream): Remove dirty_offset, len, method, + small_buffer. Order elements by decreasing size. + (struct int_stream): Remove. + (move_pos_offset): Remove usage of dirty_offset. + (reset_stream): Remove. + (do_read): Rename to raw_read, update to match new stream + interface. + (do_write): Rename to raw_write, update to new stream interface. + (raw_seek): New function. + (raw_tell): New function. + (raw_truncate): New function. + (raw_close): New function. + (raw_flush): New function. + (raw_init): New function. + (fd_alloc): Remove. + (fd_alloc_r_at): Remove. + (fd_alloc_w_at): Remove. + (fd_sfree): Remove. + (fd_seek): Remove. + (fd_truncate): Remove. + (fd_sset): Remove. + (fd_read): Remove. + (fd_write): Remove. + (fd_close): Remove. + (fd_open): Remove. + (fd_flush): Rename to buf_flush, update to new stream interface + and unix_stream. + (buf_read): New function. + (buf_write): New function. + (buf_seek): New function. + (buf_tell): New function. + (buf_truncate): New function. + (buf_close): New function. + (buf_init): New function. + (mem_alloc_r_at): Rename to mem_alloc_r, change prototype. + (mem_alloc_w_at): Rename to mem_alloc_w, change prototype. + (mem_read): Change to match new stream interface. + (mem_write): Likewise. + (mem_seek): Likewise. + (mem_tell): Likewise. + (mem_truncate): Likewise. + (mem_close): Likewise. + (mem_flush): New function. + (mem_sfree): Remove. + (empty_internal_buffer): Cast to correct type. + (open_internal): Use correct type, init function pointers. + (fd_to_stream): Test whether to open file as buffered or raw. + (output_stream): Remove mode set. + (error_stream): Likewise. + (flush_all_units_1): Use new stream interface. + (flush_all_units): Likewise. + (stream_at_bof): Remove. + (stream_at_eof): Remove. + (file_position): Remove. + (file_length): Update logic to use stream interface. + (flush): Remove. + (stream_offset): Remove. + * io/write.c (write_utf8_char4): Use int instead of size_t. + (write_x): Extra safety check. + (namelist_write_newline): Use new stream interface. + + 2009-05-16 Janne Blomqvist + + PR libfortran/39782 + * io/transfer.c (finalize_transfer): Remove extra flush. + 2009-04-21 Release Manager * GCC 4.4.0 released. diff -Nrcpad gcc-4.4.0/libgfortran/Makefile.am gcc-4.4.1/libgfortran/Makefile.am *** gcc-4.4.0/libgfortran/Makefile.am Thu Aug 14 18:31:32 2008 --- gcc-4.4.1/libgfortran/Makefile.am Wed Jun 3 19:39:09 2009 *************** intrinsics/associated.c \ *** 58,63 **** --- 58,64 ---- intrinsics/abort.c \ intrinsics/access.c \ intrinsics/args.c \ + intrinsics/bit_intrinsics.c \ intrinsics/c99_functions.c \ intrinsics/chdir.c \ intrinsics/chmod.c \ diff -Nrcpad gcc-4.4.0/libgfortran/Makefile.in gcc-4.4.1/libgfortran/Makefile.in *** gcc-4.4.0/libgfortran/Makefile.in Tue Apr 21 09:08:08 2009 --- gcc-4.4.1/libgfortran/Makefile.in Wed Jul 22 07:43:59 2009 *************** am__libgfortran_la_SOURCES_DIST = runtim *** 416,424 **** io/size_from_kind.c io/transfer.c io/unit.c io/unix.c \ io/write.c io/fbuf.c intrinsics/associated.c \ intrinsics/abort.c intrinsics/access.c intrinsics/args.c \ ! intrinsics/c99_functions.c intrinsics/chdir.c \ ! intrinsics/chmod.c intrinsics/clock.c intrinsics/cpu_time.c \ ! intrinsics/cshift0.c intrinsics/ctime.c \ intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \ intrinsics/eoshift0.c intrinsics/eoshift2.c \ intrinsics/erfc_scaled.c intrinsics/etime.c intrinsics/exit.c \ --- 416,424 ---- io/size_from_kind.c io/transfer.c io/unit.c io/unix.c \ io/write.c io/fbuf.c intrinsics/associated.c \ intrinsics/abort.c intrinsics/access.c intrinsics/args.c \ ! intrinsics/bit_intrinsics.c intrinsics/c99_functions.c \ ! intrinsics/chdir.c intrinsics/chmod.c intrinsics/clock.c \ ! intrinsics/cpu_time.c intrinsics/cshift0.c intrinsics/ctime.c \ intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \ intrinsics/eoshift0.c intrinsics/eoshift2.c \ intrinsics/erfc_scaled.c intrinsics/etime.c intrinsics/exit.c \ *************** am__objects_35 = close.lo file_pos.lo fo *** 711,719 **** intrinsics.lo list_read.lo lock.lo open.lo read.lo \ size_from_kind.lo transfer.lo unit.lo unix.lo write.lo fbuf.lo am__objects_36 = associated.lo abort.lo access.lo args.lo \ ! c99_functions.lo chdir.lo chmod.lo clock.lo cpu_time.lo \ ! cshift0.lo ctime.lo date_and_time.lo dtime.lo env.lo \ ! eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \ fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \ ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \ kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \ --- 711,719 ---- intrinsics.lo list_read.lo lock.lo open.lo read.lo \ size_from_kind.lo transfer.lo unit.lo unix.lo write.lo fbuf.lo am__objects_36 = associated.lo abort.lo access.lo args.lo \ ! bit_intrinsics.lo c99_functions.lo chdir.lo chmod.lo clock.lo \ ! cpu_time.lo cshift0.lo ctime.lo date_and_time.lo dtime.lo \ ! env.lo eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \ fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \ ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \ kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \ *************** intrinsics/associated.c \ *** 987,992 **** --- 987,993 ---- intrinsics/abort.c \ intrinsics/access.c \ intrinsics/args.c \ + intrinsics/bit_intrinsics.c \ intrinsics/c99_functions.c \ intrinsics/chdir.c \ intrinsics/chmod.c \ *************** distclean-compile: *** 1801,1806 **** --- 1802,1808 ---- @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/associated.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backtrace.Plo@am__quote@ + @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bit_intrinsics.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/c99_functions.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/chdir.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/chmod.Plo@am__quote@ *************** args.lo: intrinsics/args.c *** 5319,5324 **** --- 5321,5333 ---- @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o args.lo `test -f 'intrinsics/args.c' || echo '$(srcdir)/'`intrinsics/args.c + bit_intrinsics.lo: intrinsics/bit_intrinsics.c + @am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT bit_intrinsics.lo -MD -MP -MF "$(DEPDIR)/bit_intrinsics.Tpo" -c -o bit_intrinsics.lo `test -f 'intrinsics/bit_intrinsics.c' || echo '$(srcdir)/'`intrinsics/bit_intrinsics.c; \ + @am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/bit_intrinsics.Tpo" "$(DEPDIR)/bit_intrinsics.Plo"; else rm -f "$(DEPDIR)/bit_intrinsics.Tpo"; exit 1; fi + @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='intrinsics/bit_intrinsics.c' object='bit_intrinsics.lo' libtool=yes @AMDEPBACKSLASH@ + @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ + @am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o bit_intrinsics.lo `test -f 'intrinsics/bit_intrinsics.c' || echo '$(srcdir)/'`intrinsics/bit_intrinsics.c + c99_functions.lo: intrinsics/c99_functions.c @am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT c99_functions.lo -MD -MP -MF "$(DEPDIR)/c99_functions.Tpo" -c -o c99_functions.lo `test -f 'intrinsics/c99_functions.c' || echo '$(srcdir)/'`intrinsics/c99_functions.c; \ @am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/c99_functions.Tpo" "$(DEPDIR)/c99_functions.Plo"; else rm -f "$(DEPDIR)/c99_functions.Tpo"; exit 1; fi diff -Nrcpad gcc-4.4.0/libgfortran/gfortran.map gcc-4.4.1/libgfortran/gfortran.map *** gcc-4.4.0/libgfortran/gfortran.map Sun Jul 27 10:45:44 2008 --- gcc-4.4.1/libgfortran/gfortran.map Wed Jun 3 19:39:09 2009 *************** GFORTRAN_1.1 { *** 1090,1095 **** --- 1090,1102 ---- _gfortran_unpack1_char4; } GFORTRAN_1.0; + + GFORTRAN_1.2 { + global: + _gfortran_clz128; + _gfortran_ctz128; + } GFORTRAN_1.1; + F2C_1.0 { global: _gfortran_f2c_specific__abs_c4; diff -Nrcpad gcc-4.4.0/libgfortran/intrinsics/bit_intrinsics.c gcc-4.4.1/libgfortran/intrinsics/bit_intrinsics.c *** gcc-4.4.0/libgfortran/intrinsics/bit_intrinsics.c Thu Jan 1 00:00:00 1970 --- gcc-4.4.1/libgfortran/intrinsics/bit_intrinsics.c Wed Jun 3 19:39:09 2009 *************** *** 0 **** --- 1,138 ---- + /* Implementation of the bit intrinsics not implemented as GCC builtins. + Copyright (C) 2009 Free Software Foundation, Inc. + + This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + + 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. + + Under Section 7 of GPL version 3, you are granted additional + permissions described in the GCC Runtime Library Exception, version + 3.1, as published by the Free Software Foundation. + + You should have received a copy of the GNU General Public License and + a copy of the GCC Runtime Library Exception along with this program; + see the files COPYING3 and COPYING.RUNTIME respectively. If not, see + . */ + + #include "libgfortran.h" + + + #ifdef HAVE_GFC_INTEGER_16 + extern int clz128 (GFC_INTEGER_16); + export_proto(clz128); + + int + clz128 (GFC_INTEGER_16 x) + { + int res = 127; + + // We can't write 0xFFFFFFFFFFFFFFFF0000000000000000, so we work around it + if (x & ((__uint128_t) 0xFFFFFFFFFFFFFFFF << 64)) + { + res -= 64; + x >>= 64; + } + + if (x & 0xFFFFFFFF00000000) + { + res -= 32; + x >>= 32; + } + + if (x & 0xFFFF0000) + { + res -= 16; + x >>= 16; + } + + if (x & 0xFF00) + { + res -= 8; + x >>= 8; + } + + if (x & 0xF0) + { + res -= 4; + x >>= 4; + } + + if (x & 0xC) + { + res -= 2; + x >>= 2; + } + + if (x & 0x2) + { + res -= 1; + x >>= 1; + } + + return res; + } + #endif + + + #ifdef HAVE_GFC_INTEGER_16 + extern int ctz128 (GFC_INTEGER_16); + export_proto(ctz128); + + int + ctz128 (GFC_INTEGER_16 x) + { + int res = 0; + + if ((x & 0xFFFFFFFFFFFFFFFF) == 0) + { + res += 64; + x >>= 64; + } + + if ((x & 0xFFFFFFFF) == 0) + { + res += 32; + x >>= 32; + } + + if ((x & 0xFFFF) == 0) + { + res += 16; + x >>= 16; + } + + if ((x & 0xFF) == 0) + { + res += 8; + x >>= 8; + } + + if ((x & 0xF) == 0) + { + res += 4; + x >>= 4; + } + + if ((x & 0x3) == 0) + { + res += 2; + x >>= 2; + } + + if ((x & 0x1) == 0) + { + res += 1; + x >>= 1; + } + + return res; + } + #endif diff -Nrcpad gcc-4.4.0/libgfortran/io/fbuf.c gcc-4.4.1/libgfortran/io/fbuf.c *** gcc-4.4.0/libgfortran/io/fbuf.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/fbuf.c Wed May 27 01:21:22 2009 *************** see the files COPYING3 and COPYING.RUNTI *** 28,35 **** #include void ! fbuf_init (gfc_unit * u, size_t len) { if (len == 0) len = 512; /* Default size. */ --- 28,38 ---- #include + //#define FBUF_DEBUG + + void ! fbuf_init (gfc_unit * u, int len) { if (len == 0) len = 512; /* Default size. */ *************** fbuf_init (gfc_unit * u, size_t len) *** 37,50 **** u->fbuf = get_mem (sizeof (fbuf)); u->fbuf->buf = get_mem (len); u->fbuf->len = len; ! u->fbuf->act = u->fbuf->flushed = u->fbuf->pos = 0; ! } ! ! ! void ! fbuf_reset (gfc_unit * u) ! { ! u->fbuf->act = u->fbuf->flushed = u->fbuf->pos = 0; } --- 40,46 ---- u->fbuf = get_mem (sizeof (fbuf)); u->fbuf->buf = get_mem (len); u->fbuf->len = len; ! u->fbuf->act = u->fbuf->pos = 0; } *************** fbuf_destroy (gfc_unit * u) *** 56,113 **** if (u->fbuf->buf) free_mem (u->fbuf->buf); free_mem (u->fbuf); } /* Return a pointer to the current position in the buffer, and increase the pointer by len. Makes sure that the buffer is big enough, ! reallocating if necessary. If the buffer is not big enough, there are ! three cases to consider: ! 1. If we haven't flushed anything, realloc ! 2. If we have flushed enough that by discarding the flushed bytes ! the request fits into the buffer, do that. ! 3. Else allocate a new buffer, memcpy unflushed active bytes from old ! buffer. */ char * ! fbuf_alloc (gfc_unit * u, size_t len) { ! size_t newlen; char *dest; if (u->fbuf->pos + len > u->fbuf->len) { ! if (u->fbuf->flushed == 0) ! { ! /* Round up to nearest multiple of the current buffer length. */ ! newlen = ((u->fbuf->pos + len) / u->fbuf->len + 1) * u->fbuf->len; ! dest = realloc (u->fbuf->buf, newlen); ! if (dest == NULL) ! return NULL; ! u->fbuf->buf = dest; ! u->fbuf->len = newlen; ! } ! else if (u->fbuf->act - u->fbuf->flushed + len < u->fbuf->len) ! { ! memmove (u->fbuf->buf, u->fbuf->buf + u->fbuf->flushed, ! u->fbuf->act - u->fbuf->flushed); ! u->fbuf->act -= u->fbuf->flushed; ! u->fbuf->pos -= u->fbuf->flushed; ! u->fbuf->flushed = 0; ! } ! else ! { ! /* Most general case, flushed != 0, request doesn't fit. */ ! newlen = ((u->fbuf->pos - u->fbuf->flushed + len) ! / u->fbuf->len + 1) * u->fbuf->len; ! dest = get_mem (newlen); ! memcpy (dest, u->fbuf->buf + u->fbuf->flushed, ! u->fbuf->act - u->fbuf->flushed); ! u->fbuf->act -= u->fbuf->flushed; ! u->fbuf->pos -= u->fbuf->flushed; ! u->fbuf->flushed = 0; ! u->fbuf->buf = dest; ! u->fbuf->len = newlen; ! } } dest = u->fbuf->buf + u->fbuf->pos; --- 52,130 ---- if (u->fbuf->buf) free_mem (u->fbuf->buf); free_mem (u->fbuf); + u->fbuf = NULL; + } + + + static void + #ifdef FBUF_DEBUG + fbuf_debug (gfc_unit * u, const char * format, ...) + { + va_list args; + va_start(args, format); + vfprintf(stderr, format, args); + va_end(args); + fprintf (stderr, "fbuf_debug pos: %d, act: %d, buf: ''", + u->fbuf->pos, u->fbuf->act); + for (int ii = 0; ii < u->fbuf->act; ii++) + { + putc (u->fbuf->buf[ii], stderr); + } + fprintf (stderr, "''\n"); + } + #else + fbuf_debug (gfc_unit * u __attribute__ ((unused)), + const char * format __attribute__ ((unused)), + ...) {} + #endif + + + + /* You should probably call this before doing a physical seek on the + underlying device. Returns how much the physical position was + modified. */ + + int + fbuf_reset (gfc_unit * u) + { + int seekval = 0; + + if (!u->fbuf) + return 0; + + fbuf_debug (u, "fbuf_reset: "); + fbuf_flush (u, u->mode); + /* If we read past the current position, seek the underlying device + back. */ + if (u->mode == READING && u->fbuf->act > u->fbuf->pos) + { + seekval = - (u->fbuf->act - u->fbuf->pos); + fbuf_debug (u, "fbuf_reset seekval %d, ", seekval); + } + u->fbuf->act = u->fbuf->pos = 0; + return seekval; } /* Return a pointer to the current position in the buffer, and increase the pointer by len. Makes sure that the buffer is big enough, ! reallocating if necessary. */ char * ! fbuf_alloc (gfc_unit * u, int len) { ! int newlen; char *dest; + fbuf_debug (u, "fbuf_alloc len %d, ", len); if (u->fbuf->pos + len > u->fbuf->len) { ! /* Round up to nearest multiple of the current buffer length. */ ! newlen = ((u->fbuf->pos + len) / u->fbuf->len + 1) * u->fbuf->len; ! dest = realloc (u->fbuf->buf, newlen); ! if (dest == NULL) ! return NULL; ! u->fbuf->buf = dest; ! u->fbuf->len = newlen; } dest = u->fbuf->buf + u->fbuf->pos; *************** fbuf_alloc (gfc_unit * u, size_t len) *** 118,159 **** } ! int ! fbuf_flush (gfc_unit * u, int record_done) { ! int status; ! size_t nbytes; if (!u->fbuf) return 0; ! if (u->fbuf->act - u->fbuf->flushed != 0) { ! if (record_done) ! nbytes = u->fbuf->act - u->fbuf->flushed; ! else ! nbytes = u->fbuf->pos - u->fbuf->flushed; ! status = swrite (u->s, u->fbuf->buf + u->fbuf->flushed, &nbytes); ! u->fbuf->flushed += nbytes; } ! else ! status = 0; ! if (record_done) ! fbuf_reset (u); ! return status; } int ! fbuf_seek (gfc_unit * u, gfc_offset off) { ! gfc_offset pos = u->fbuf->pos + off; ! /* Moving to the left past the flushed marked would imply moving past ! the left tab limit, which is never allowed. So return error if ! that is attempted. */ ! if (pos < (gfc_offset) u->fbuf->flushed) return -1; ! u->fbuf->pos = pos; ! return 0; } --- 135,268 ---- } ! /* mode argument is WRITING for write mode and READING for read ! mode. Return value is 0 for success, -1 on failure. */ int ! fbuf_flush (gfc_unit * u, unit_mode mode) { ! int nwritten; if (!u->fbuf) return 0; ! ! fbuf_debug (u, "fbuf_flush with mode %d: ", mode); ! ! if (mode == WRITING) { ! if (u->fbuf->pos > 0) ! { ! nwritten = swrite (u->s, u->fbuf->buf, u->fbuf->pos); ! if (nwritten < 0) ! return -1; ! } } ! /* Salvage remaining bytes for both reading and writing. This ! happens with the combination of advance='no' and T edit ! descriptors leaving the final position somewhere not at the end ! of the record. For reading, this also happens if we sread() past ! the record boundary. */ ! if (u->fbuf->act > u->fbuf->pos && u->fbuf->pos > 0) ! memmove (u->fbuf->buf, u->fbuf->buf + u->fbuf->pos, ! u->fbuf->act - u->fbuf->pos); ! ! u->fbuf->act -= u->fbuf->pos; ! u->fbuf->pos = 0; ! ! return 0; } int ! fbuf_seek (gfc_unit * u, int off, int whence) { ! if (!u->fbuf) return -1; ! ! switch (whence) ! { ! case SEEK_SET: ! break; ! case SEEK_CUR: ! off += u->fbuf->pos; ! break; ! case SEEK_END: ! off += u->fbuf->act; ! break; ! default: ! return -1; ! } ! ! fbuf_debug (u, "fbuf_seek, off %d ", off); ! /* The start of the buffer is always equal to the left tab ! limit. Moving to the left past the buffer is illegal in C and ! would also imply moving past the left tab limit, which is never ! allowed in Fortran. Similarly, seeking past the end of the buffer ! is not possible, in that case the user must make sure to allocate ! space with fbuf_alloc(). So return error if that is ! attempted. */ ! if (off < 0 || off > u->fbuf->act) ! return -1; ! u->fbuf->pos = off; ! return off; ! } ! ! ! /* Fill the buffer with bytes for reading. Returns a pointer to start ! reading from. If we hit EOF, returns a short read count. If any ! other error occurs, return NULL. After reading, the caller is ! expected to call fbuf_seek to update the position with the number ! of bytes actually processed. */ ! ! char * ! fbuf_read (gfc_unit * u, int * len) ! { ! char *ptr; ! int oldact, oldpos; ! int readlen = 0; ! ! fbuf_debug (u, "fbuf_read, len %d: ", *len); ! oldact = u->fbuf->act; ! oldpos = u->fbuf->pos; ! ptr = fbuf_alloc (u, *len); ! u->fbuf->pos = oldpos; ! if (oldpos + *len > oldact) ! { ! fbuf_debug (u, "reading %d bytes starting at %d ", ! oldpos + *len - oldact, oldact); ! readlen = sread (u->s, u->fbuf->buf + oldact, oldpos + *len - oldact); ! if (readlen < 0) ! return NULL; ! *len = oldact - oldpos + readlen; ! } ! u->fbuf->act = oldact + readlen; ! fbuf_debug (u, "fbuf_read done: "); ! return ptr; ! } ! ! ! /* When the fbuf_getc() inline function runs out of buffer space, it ! calls this function to fill the buffer with bytes for ! reading. Never call this function directly. */ ! ! int ! fbuf_getc_refill (gfc_unit * u) ! { ! int nread; ! char *p; ! ! fbuf_debug (u, "fbuf_getc_refill "); ! ! /* Read 80 bytes (average line length?). This is a compromise ! between not needing to call the read() syscall all the time and ! not having to memmove unnecessary stuff when switching to the ! next record. */ ! nread = 80; ! ! p = fbuf_read (u, &nread); ! ! if (p && nread > 0) ! return (unsigned char) u->fbuf->buf[u->fbuf->pos++]; ! else ! return EOF; } diff -Nrcpad gcc-4.4.0/libgfortran/io/file_pos.c gcc-4.4.1/libgfortran/io/file_pos.c *** gcc-4.4.0/libgfortran/io/file_pos.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/file_pos.c Wed May 27 01:21:22 2009 *************** formatted_backspace (st_parameter_filepo *** 41,57 **** { gfc_offset base; char p[READ_CHUNK]; ! size_t n; ! base = file_position (u->s) - 1; do { n = (base < READ_CHUNK) ? base : READ_CHUNK; base -= n; ! if (sseek (u->s, base) == FAILURE) goto io_error; ! if (sread (u->s, p, &n) != 0) goto io_error; /* We have moved backwards from the current position, it should --- 41,57 ---- { gfc_offset base; char p[READ_CHUNK]; ! ssize_t n; ! base = stell (u->s) - 1; do { n = (base < READ_CHUNK) ? base : READ_CHUNK; base -= n; ! if (sseek (u->s, base, SEEK_SET) < 0) goto io_error; ! if (sread (u->s, p, n) != n) goto io_error; /* We have moved backwards from the current position, it should *************** formatted_backspace (st_parameter_filepo *** 76,82 **** /* base is the new pointer. Seek to it exactly. */ done: ! if (sseek (u->s, base) == FAILURE) goto io_error; u->last_record--; u->endfile = NO_ENDFILE; --- 76,82 ---- /* base is the new pointer. Seek to it exactly. */ done: ! if (sseek (u->s, base, SEEK_SET) < 0) goto io_error; u->last_record--; u->endfile = NO_ENDFILE; *************** formatted_backspace (st_parameter_filepo *** 95,104 **** static void unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u) { ! gfc_offset m, new; GFC_INTEGER_4 m4; GFC_INTEGER_8 m8; ! size_t length; int continued; char p[sizeof (GFC_INTEGER_8)]; --- 95,104 ---- static void unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u) { ! gfc_offset m, slen; GFC_INTEGER_4 m4; GFC_INTEGER_8 m8; ! ssize_t length; int continued; char p[sizeof (GFC_INTEGER_8)]; *************** unformatted_backspace (st_parameter_file *** 109,117 **** do { ! if (sseek (u->s, file_position (u->s) - length) == FAILURE) goto io_error; ! if (sread (u->s, p, &length) != 0) goto io_error; /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ --- 109,118 ---- do { ! slen = - (gfc_offset) length; ! if (sseek (u->s, slen, SEEK_CUR) < 0) goto io_error; ! if (sread (u->s, p, length) != length) goto io_error; /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ *************** unformatted_backspace (st_parameter_file *** 159,168 **** if (continued) m = -m; ! if ((new = file_position (u->s) - m - 2*length) < 0) ! new = 0; ! ! if (sseek (u->s, new) == FAILURE) goto io_error; } while (continued); --- 160,166 ---- if (continued) m = -m; ! if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0) goto io_error; } while (continued); *************** st_backspace (st_parameter_filepos *fpp) *** 201,215 **** goto done; } ! if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED) ! { ! generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT, ! "Cannot BACKSPACE an unformatted stream file"); ! goto done; ! } - /* Make sure format buffer is flushed. */ - fbuf_flush (u, 1); /* Check for special cases involving the ENDFILE record first. */ --- 199,219 ---- goto done; } ! if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED) ! { ! generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT, ! "Cannot BACKSPACE an unformatted stream file"); ! goto done; ! } ! ! /* Make sure format buffer is flushed and reset. */ ! if (u->flags.form == FORM_FORMATTED) ! { ! int pos = fbuf_reset (u); ! if (pos != 0) ! sseek (u->s, pos, SEEK_CUR); ! } /* Check for special cases involving the ENDFILE record first. */ *************** st_backspace (st_parameter_filepos *fpp) *** 217,227 **** { u->endfile = AT_ENDFILE; u->flags.position = POSITION_APPEND; ! flush (u->s); } else { ! if (file_position (u->s) == 0) { u->flags.position = POSITION_REWIND; goto done; /* Common special case */ --- 221,231 ---- { u->endfile = AT_ENDFILE; u->flags.position = POSITION_APPEND; ! sflush (u->s); } else { ! if (stell (u->s) == 0) { u->flags.position = POSITION_REWIND; goto done; /* Common special case */ *************** st_backspace (st_parameter_filepos *fpp) *** 238,245 **** u->previous_nonadvancing_write = 0; ! flush (u->s); ! struncate (u->s); u->mode = READING; } --- 242,248 ---- u->previous_nonadvancing_write = 0; ! unit_truncate (u, stell (u->s), &fpp->common); u->mode = READING; } *************** st_backspace (st_parameter_filepos *fpp) *** 248,254 **** else unformatted_backspace (fpp, u); ! update_position (u); u->endfile = NO_ENDFILE; u->current_record = 0; u->bytes_left = 0; --- 251,257 ---- else unformatted_backspace (fpp, u); ! u->flags.position = POSITION_UNSPECIFIED; u->endfile = NO_ENDFILE; u->current_record = 0; u->bytes_left = 0; *************** st_endfile (st_parameter_filepos *fpp) *** 300,309 **** next_record (&dtp, 1); } ! flush (u->s); ! struncate (u->s); u->endfile = AFTER_ENDFILE; ! update_position (u); done: unlock_unit (u); } --- 303,312 ---- next_record (&dtp, 1); } ! unit_truncate (u, stell (u->s), &fpp->common); u->endfile = AFTER_ENDFILE; ! if (0 == stell (u->s)) ! u->flags.position = POSITION_REWIND; done: unlock_unit (u); } *************** st_rewind (st_parameter_filepos *fpp) *** 338,355 **** u->previous_nonadvancing_write = 0; ! /* Flush the buffers. If we have been writing to the file, the last ! written record is the last record in the file, so truncate the ! file now. Reset to read mode so two consecutive rewind ! statements do not delete the file contents. */ ! flush (u->s); ! if (u->mode == WRITING && u->flags.access != ACCESS_STREAM) ! struncate (u->s); - u->mode = READING; u->last_record = 0; ! if (file_position (u->s) != 0 && sseek (u->s, 0) == FAILURE) generate_error (&fpp->common, LIBERROR_OS, NULL); /* Handle special files like /dev/null differently. */ --- 341,351 ---- u->previous_nonadvancing_write = 0; ! fbuf_reset (u); u->last_record = 0; ! if (sseek (u->s, 0, SEEK_SET) < 0) generate_error (&fpp->common, LIBERROR_OS, NULL); /* Handle special files like /dev/null differently. */ *************** st_rewind (st_parameter_filepos *fpp) *** 361,367 **** else { /* Set this for compatibilty with g77 for /dev/null. */ ! if (file_length (u->s) == 0 && file_position (u->s) == 0) u->endfile = AT_ENDFILE; /* Future refinements on special files can go here. */ } --- 357,363 ---- else { /* Set this for compatibilty with g77 for /dev/null. */ ! if (file_length (u->s) == 0 && stell (u->s) == 0) u->endfile = AT_ENDFILE; /* Future refinements on special files can go here. */ } *************** st_flush (st_parameter_filepos *fpp) *** 392,398 **** u = find_unit (fpp->common.unit); if (u != NULL) { ! flush (u->s); unlock_unit (u); } else --- 388,398 ---- u = find_unit (fpp->common.unit); if (u != NULL) { ! /* Make sure format buffer is flushed. */ ! if (u->flags.form == FORM_FORMATTED) ! fbuf_flush (u, u->mode); ! ! sflush (u->s); unlock_unit (u); } else diff -Nrcpad gcc-4.4.0/libgfortran/io/format.c gcc-4.4.1/libgfortran/io/format.c *** gcc-4.4.0/libgfortran/io/format.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/format.c Thu Jun 11 12:49:35 2009 *************** format_data; *** 58,64 **** static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0, NULL }; ! /* Error messages */ static const char posint_required[] = "Positive width required in format", period_required[] = "Period required in format", --- 58,64 ---- static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0, NULL }; ! /* Error messages. */ static const char posint_required[] = "Positive width required in format", period_required[] = "Period required in format", *************** next_char (format_data *fmt, int literal *** 85,91 **** return -1; fmt->format_string_len--; ! fmt->error_element = c = toupper (*fmt->format_string++); } while ((c == ' ' || c == '\t') && !literal); --- 85,92 ---- return -1; fmt->format_string_len--; ! c = toupper (*fmt->format_string++); ! fmt->error_element = c; } while ((c == ' ' || c == '\t') && !literal); *************** format_lex (format_data *fmt) *** 179,184 **** --- 180,193 ---- switch (c) { + case '(': + token = FMT_LPAREN; + break; + + case ')': + token = FMT_RPAREN; + break; + case '-': negative_flag = 1; /* Fall Through */ *************** format_lex (format_data *fmt) *** 271,284 **** break; - case '(': - token = FMT_LPAREN; - break; - - case ')': - token = FMT_RPAREN; - break; - case 'X': token = FMT_X; break; --- 280,285 ---- *************** format_error (st_parameter_dt *dtp, cons *** 994,999 **** --- 995,1027 ---- } + /* revert()-- Do reversion of the format. Control reverts to the left + * parenthesis that matches the rightmost right parenthesis. From our + * tree structure, we are looking for the rightmost parenthesis node + * at the second level, the first level always being a single + * parenthesis node. If this node doesn't exit, we use the top + * level. */ + + static void + revert (st_parameter_dt *dtp) + { + fnode *f, *r; + format_data *fmt = dtp->u.p.fmt; + + dtp->u.p.reversion_flag = 1; + + r = NULL; + + for (f = fmt->array.array[0].u.child; f; f = f->next) + if (f->format == FMT_LPAREN) + r = f; + + /* If r is NULL because no node was found, the whole tree will be used */ + + fmt->array.array[0].current = r; + fmt->array.array[0].count = 0; + } + /* parse_format()-- Parse a format string. */ void *************** parse_format (st_parameter_dt *dtp) *** 1036,1069 **** } - /* revert()-- Do reversion of the format. Control reverts to the left - * parenthesis that matches the rightmost right parenthesis. From our - * tree structure, we are looking for the rightmost parenthesis node - * at the second level, the first level always being a single - * parenthesis node. If this node doesn't exit, we use the top - * level. */ - - static void - revert (st_parameter_dt *dtp) - { - fnode *f, *r; - format_data *fmt = dtp->u.p.fmt; - - dtp->u.p.reversion_flag = 1; - - r = NULL; - - for (f = fmt->array.array[0].u.child; f; f = f->next) - if (f->format == FMT_LPAREN) - r = f; - - /* If r is NULL because no node was found, the whole tree will be used */ - - fmt->array.array[0].current = r; - fmt->array.array[0].count = 0; - } - - /* next_format0()-- Get the next format node without worrying about * reversion. Returns NULL when we hit the end of the list. * Parenthesis nodes are incremented after the list has been --- 1064,1069 ---- diff -Nrcpad gcc-4.4.0/libgfortran/io/intrinsics.c gcc-4.4.1/libgfortran/io/intrinsics.c *** gcc-4.4.0/libgfortran/io/intrinsics.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/intrinsics.c Wed May 27 01:21:22 2009 *************** int *** 41,61 **** PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len) { int ret; - size_t s; gfc_unit * u = find_unit (*unit); if (u == NULL) return -1; ! s = 1; memset (c, ' ', c_len); ! ret = sread (u->s, c, &s); unlock_unit (u); ! if (ret != 0) return ret; ! if (s != 1) return -1; else return 0; --- 41,66 ---- PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len) { int ret; gfc_unit * u = find_unit (*unit); if (u == NULL) return -1; ! fbuf_reset (u); ! if (u->mode == WRITING) ! { ! sflush (u->s); ! u->mode = READING; ! } ! memset (c, ' ', c_len); ! ret = sread (u->s, c, 1); unlock_unit (u); ! if (ret < 0) return ret; ! if (ret != 1) return -1; else return 0; *************** int *** 114,130 **** PREFIX(fputc) (const int * unit, char * c, gfc_charlen_type c_len __attribute__((unused))) { ! size_t s; ! int ret; gfc_unit * u = find_unit (*unit); if (u == NULL) return -1; ! s = 1; ! ret = swrite (u->s, c, &s); unlock_unit (u); ! return ret; } --- 119,142 ---- PREFIX(fputc) (const int * unit, char * c, gfc_charlen_type c_len __attribute__((unused))) { ! ssize_t s; gfc_unit * u = find_unit (*unit); if (u == NULL) return -1; ! fbuf_reset (u); ! if (u->mode == READING) ! { ! sflush (u->s); ! u->mode = WRITING; ! } ! ! s = swrite (u->s, c, 1); unlock_unit (u); ! if (s < 0) ! return -1; ! return 0; } *************** flush_i4 (GFC_INTEGER_4 *unit) *** 191,197 **** us = find_unit (*unit); if (us != NULL) { ! flush (us->s); unlock_unit (us); } } --- 203,209 ---- us = find_unit (*unit); if (us != NULL) { ! sflush (us->s); unlock_unit (us); } } *************** flush_i8 (GFC_INTEGER_8 *unit) *** 214,220 **** us = find_unit (*unit); if (us != NULL) { ! flush (us->s); unlock_unit (us); } } --- 226,232 ---- us = find_unit (*unit); if (us != NULL) { ! sflush (us->s); unlock_unit (us); } } *************** void *** 229,250 **** fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status) { gfc_unit * u = find_unit (*unit); ! try result = FAILURE; if (u != NULL && is_seekable(u->s)) { ! if (*whence == 0) ! result = sseek(u->s, *offset); /* SEEK_SET */ ! else if (*whence == 1) ! result = sseek(u->s, file_position(u->s) + *offset); /* SEEK_CUR */ ! else if (*whence == 2) ! result = sseek(u->s, file_length(u->s) + *offset); /* SEEK_END */ unlock_unit (u); } if (status) ! *status = (result == FAILURE ? -1 : 0); } --- 241,257 ---- fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status) { gfc_unit * u = find_unit (*unit); ! ssize_t result = -1; if (u != NULL && is_seekable(u->s)) { ! result = sseek(u->s, *offset, *whence); unlock_unit (u); } if (status) ! *status = (result < 0 ? -1 : 0); } *************** PREFIX(ftell) (int * unit) *** 261,267 **** size_t ret; if (u == NULL) return ((size_t) -1); ! ret = (size_t) stream_offset (u->s); unlock_unit (u); return ret; } --- 268,274 ---- size_t ret; if (u == NULL) return ((size_t) -1); ! ret = (size_t) stell (u->s); unlock_unit (u); return ret; } *************** PREFIX(ftell) (int * unit) *** 277,283 **** *offset = -1; \ else \ { \ ! *offset = stream_offset (u->s); \ unlock_unit (u); \ } \ } --- 284,290 ---- *offset = -1; \ else \ { \ ! *offset = stell (u->s); \ unlock_unit (u); \ } \ } diff -Nrcpad gcc-4.4.0/libgfortran/io/io.h gcc-4.4.1/libgfortran/io/io.h *** gcc-4.4.0/libgfortran/io/io.h Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/io.h Thu Jun 11 12:49:35 2009 *************** struct st_parameter_dt; *** 46,79 **** typedef struct stream { ! char *(*alloc_w_at) (struct stream *, int *); ! try (*sfree) (struct stream *); ! try (*close) (struct stream *); ! try (*seek) (struct stream *, gfc_offset); ! try (*trunc) (struct stream *); ! int (*read) (struct stream *, void *, size_t *); ! int (*write) (struct stream *, const void *, size_t *); ! try (*set) (struct stream *, int, size_t); } stream; ! typedef enum ! { SYNC_BUFFERED, SYNC_UNBUFFERED, ASYNC } ! io_mode; ! /* Macros for doing file I/O given a stream. */ ! #define sfree(s) ((s)->sfree)(s) ! #define sclose(s) ((s)->close)(s) ! #define salloc_w(s, len) ((s)->alloc_w_at)(s, len) ! #define sseek(s, pos) ((s)->seek)(s, pos) ! #define struncate(s) ((s)->trunc)(s) ! #define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes) ! #define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes) - #define sset(s, c, n) ((s)->set)(s, c, n) /* Macros for testing what kinds of I/O we are doing. */ --- 46,105 ---- typedef struct stream { ! ssize_t (*read) (struct stream *, void *, ssize_t); ! ssize_t (*write) (struct stream *, const void *, ssize_t); ! off_t (*seek) (struct stream *, off_t, int); ! off_t (*tell) (struct stream *); ! /* Avoid keyword truncate due to AIX namespace collision. */ ! int (*trunc) (struct stream *, off_t); ! int (*flush) (struct stream *); ! int (*close) (struct stream *); } stream; ! /* Inline functions for doing file I/O given a stream. */ ! static inline ssize_t ! sread (stream * s, void * buf, ssize_t nbyte) ! { ! return s->read (s, buf, nbyte); ! } ! static inline ssize_t ! swrite (stream * s, const void * buf, ssize_t nbyte) ! { ! return s->write (s, buf, nbyte); ! } ! static inline off_t ! sseek (stream * s, off_t offset, int whence) ! { ! return s->seek (s, offset, whence); ! } ! static inline off_t ! stell (stream * s) ! { ! return s->tell (s); ! } ! static inline int ! struncate (stream * s, off_t length) ! { ! return s->trunc (s, length); ! } ! ! static inline int ! sflush (stream * s) ! { ! return s->flush (s); ! } ! ! static inline int ! sclose (stream * s) ! { ! return s->close (s); ! } /* Macros for testing what kinds of I/O we are doing. */ *************** array_loop_spec; *** 124,130 **** typedef struct namelist_type { - /* Object type, stored as GFC_DTYPE_xxxx. */ bt type; --- 150,155 ---- *************** typedef struct st_parameter_dt *** 461,469 **** /* A flag used to identify when a non-standard expanded namelist read has occurred. */ int expanded_read; ! /* Storage area for values except for strings. Must be large ! enough to hold a complex value (two reals) of the largest ! kind. */ char value[32]; GFC_IO_INT size_used; } p; --- 486,494 ---- /* A flag used to identify when a non-standard expanded namelist read has occurred. */ int expanded_read; ! /* Storage area for values except for strings. Must be ! large enough to hold a complex value (two reals) of the ! largest kind. */ char value[32]; GFC_IO_INT size_used; } p; *************** unit_flags; *** 535,544 **** typedef struct fbuf { char *buf; /* Start of buffer. */ ! size_t len; /* Length of buffer. */ ! size_t act; /* Active bytes in buffer. */ ! size_t flushed; /* Flushed bytes from beginning of buffer. */ ! size_t pos; /* Current position in buffer. */ } fbuf; --- 560,568 ---- typedef struct fbuf { char *buf; /* Start of buffer. */ ! int len; /* Length of buffer. */ ! int act; /* Active bytes in buffer. */ ! int pos; /* Current position in buffer. */ } fbuf; *************** typedef struct gfc_unit *** 596,602 **** int file_len; char *file; ! /* Formatting buffer. */ struct fbuf *fbuf; } --- 620,626 ---- int file_len; char *file; ! /* Formatting buffer. */ struct fbuf *fbuf; } *************** fnode; *** 668,676 **** /* unix.c */ - extern int move_pos_offset (stream *, int); - internal_proto(move_pos_offset); - extern int compare_files (stream *, stream *); internal_proto(compare_files); --- 692,697 ---- *************** internal_proto(open_external); *** 680,685 **** --- 701,712 ---- extern stream *open_internal (char *, int, gfc_offset); internal_proto(open_internal); + extern char * mem_alloc_w (stream *, int *); + internal_proto(mem_alloc_w); + + extern char * mem_alloc_r (stream *, int *); + internal_proto(mem_alloc_w); + extern stream *input_stream (void); internal_proto(input_stream); *************** internal_proto(compare_file_filename); *** 695,706 **** extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len); internal_proto(find_file); - extern int stream_at_bof (stream *); - internal_proto(stream_at_bof); - - extern int stream_at_eof (stream *); - internal_proto(stream_at_eof); - extern int delete_file (gfc_unit *); internal_proto(delete_file); --- 722,727 ---- *************** internal_proto(inquire_readwrite); *** 731,766 **** extern gfc_offset file_length (stream *); internal_proto(file_length); - extern gfc_offset file_position (stream *); - internal_proto(file_position); - extern int is_seekable (stream *); internal_proto(is_seekable); extern int is_special (stream *); internal_proto(is_special); - extern int is_preconnected (stream *); - internal_proto(is_preconnected); - extern void flush_if_preconnected (stream *); internal_proto(flush_if_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 gfc_offset stream_offset (stream *s); - internal_proto(stream_offset); - extern int unpack_filename (char *, const char *, int); internal_proto(unpack_filename); --- 752,775 ---- *************** internal_proto(update_position); *** 804,809 **** --- 813,821 ---- extern void finish_last_advance_record (gfc_unit *u); internal_proto (finish_last_advance_record); + extern int unit_truncate (gfc_unit *, gfc_offset, st_parameter_common *); + internal_proto (unit_truncate); + /* open.c */ extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *); *************** internal_proto(free_format_data); *** 833,839 **** extern const char *type_name (bt); internal_proto(type_name); ! extern try read_block_form (st_parameter_dt *, void *, size_t *); internal_proto(read_block_form); extern char *read_sf (st_parameter_dt *, int *, int); --- 845,851 ---- extern const char *type_name (bt); internal_proto(type_name); ! extern void * read_block_form (st_parameter_dt *, int *); internal_proto(read_block_form); extern char *read_sf (st_parameter_dt *, int *, int); *************** internal_proto (reverse_memcpy); *** 859,864 **** --- 871,879 ---- extern void st_wait (st_parameter_wait *); export_proto(st_wait); + extern void hit_eof (st_parameter_dt *); + internal_proto(hit_eof); + /* read.c */ extern void set_integer (void *, GFC_INTEGER_LARGEST, int); *************** extern size_t size_from_complex_kind (in *** 965,988 **** internal_proto(size_from_complex_kind); /* fbuf.c */ ! extern void fbuf_init (gfc_unit *, size_t); internal_proto(fbuf_init); extern void fbuf_destroy (gfc_unit *); internal_proto(fbuf_destroy); ! extern void fbuf_reset (gfc_unit *); internal_proto(fbuf_reset); ! extern char * fbuf_alloc (gfc_unit *, size_t); internal_proto(fbuf_alloc); ! extern int fbuf_flush (gfc_unit *, int); internal_proto(fbuf_flush); ! extern int fbuf_seek (gfc_unit *, gfc_offset); internal_proto(fbuf_seek); /* lock.c */ extern void free_ionml (st_parameter_dt *); internal_proto(free_ionml); --- 980,1018 ---- internal_proto(size_from_complex_kind); /* fbuf.c */ ! extern void fbuf_init (gfc_unit *, int); internal_proto(fbuf_init); extern void fbuf_destroy (gfc_unit *); internal_proto(fbuf_destroy); ! extern int fbuf_reset (gfc_unit *); internal_proto(fbuf_reset); ! extern char * fbuf_alloc (gfc_unit *, int); internal_proto(fbuf_alloc); ! extern int fbuf_flush (gfc_unit *, unit_mode); internal_proto(fbuf_flush); ! extern int fbuf_seek (gfc_unit *, int, int); internal_proto(fbuf_seek); + extern char * fbuf_read (gfc_unit *, int *); + internal_proto(fbuf_read); + + /* Never call this function, only use fbuf_getc(). */ + extern int fbuf_getc_refill (gfc_unit *); + internal_proto(fbuf_getc_refill); + + static inline int + fbuf_getc (gfc_unit * u) + { + if (u->fbuf->pos < u->fbuf->act) + return (unsigned char) u->fbuf->buf[u->fbuf->pos++]; + return fbuf_getc_refill (u); + } + /* lock.c */ extern void free_ionml (st_parameter_dt *); internal_proto(free_ionml); diff -Nrcpad gcc-4.4.0/libgfortran/io/list_read.c gcc-4.4.1/libgfortran/io/list_read.c *** gcc-4.4.0/libgfortran/io/list_read.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/list_read.c Tue Jun 9 03:15:04 2009 *************** see the files COPYING3 and COPYING.RUNTI *** 28,33 **** --- 28,34 ---- #include "io.h" #include + #include #include *************** push_char (st_parameter_dt *dtp, char c) *** 74,82 **** if (dtp->u.p.saved_string == NULL) { ! if (dtp->u.p.scratch == NULL) ! dtp->u.p.scratch = get_mem (SCRATCH_SIZE); ! dtp->u.p.saved_string = dtp->u.p.scratch; memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE); dtp->u.p.saved_length = SCRATCH_SIZE; dtp->u.p.saved_used = 0; --- 75,82 ---- if (dtp->u.p.saved_string == NULL) { ! dtp->u.p.saved_string = get_mem (SCRATCH_SIZE); ! // memset below should be commented out. memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE); dtp->u.p.saved_length = SCRATCH_SIZE; dtp->u.p.saved_used = 0; *************** push_char (st_parameter_dt *dtp, char c) *** 85,99 **** if (dtp->u.p.saved_used >= dtp->u.p.saved_length) { dtp->u.p.saved_length = 2 * dtp->u.p.saved_length; ! new = get_mem (2 * dtp->u.p.saved_length); ! ! memset (new, 0, 2 * dtp->u.p.saved_length); ! ! memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used); ! if (dtp->u.p.saved_string != dtp->u.p.scratch) ! free_mem (dtp->u.p.saved_string); ! dtp->u.p.saved_string = new; } dtp->u.p.saved_string[dtp->u.p.saved_used++] = c; --- 85,99 ---- if (dtp->u.p.saved_used >= dtp->u.p.saved_length) { dtp->u.p.saved_length = 2 * dtp->u.p.saved_length; ! new = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length); ! if (new == NULL) ! generate_error (&dtp->common, LIBERROR_OS, NULL); dtp->u.p.saved_string = new; + + // Also this should not be necessary. + memset (new + dtp->u.p.saved_used, 0, + dtp->u.p.saved_length - dtp->u.p.saved_used); + } dtp->u.p.saved_string[dtp->u.p.saved_used++] = c; *************** free_saved (st_parameter_dt *dtp) *** 108,115 **** if (dtp->u.p.saved_string == NULL) return; ! if (dtp->u.p.saved_string != dtp->u.p.scratch) ! free_mem (dtp->u.p.saved_string); dtp->u.p.saved_string = NULL; dtp->u.p.saved_used = 0; --- 108,114 ---- if (dtp->u.p.saved_string == NULL) return; ! free_mem (dtp->u.p.saved_string); dtp->u.p.saved_string = NULL; dtp->u.p.saved_used = 0; *************** free_line (st_parameter_dt *dtp) *** 135,143 **** static char next_char (st_parameter_dt *dtp) { ! size_t length; gfc_offset record; char c; if (dtp->u.p.last_char != '\0') { --- 134,143 ---- static char next_char (st_parameter_dt *dtp) { ! ssize_t length; gfc_offset record; char c; + int cc; if (dtp->u.p.last_char != '\0') { *************** next_char (st_parameter_dt *dtp) *** 189,195 **** } record *= dtp->u.p.current_unit->recl; ! if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) longjmp (*dtp->u.p.eof_jump, 1); dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; --- 189,195 ---- } record *= dtp->u.p.current_unit->recl; ! if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) longjmp (*dtp->u.p.eof_jump, 1); dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; *************** next_char (st_parameter_dt *dtp) *** 199,217 **** /* Get the next character and handle end-of-record conditions. */ - length = 1; - - if (sread (dtp->u.p.current_unit->s, &c, &length) != 0) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return '\0'; - } - - if (is_stream_io (dtp) && length == 1) - dtp->u.p.current_unit->strm_pos++; - if (is_internal_unit (dtp)) { if (is_array_io (dtp)) { /* Check whether we hit EOF. */ --- 199,213 ---- /* Get the next character and handle end-of-record conditions. */ if (is_internal_unit (dtp)) { + length = sread (dtp->u.p.current_unit->s, &c, 1); + if (length < 0) + { + generate_error (&dtp->common, LIBERROR_OS, NULL); + return '\0'; + } + if (is_array_io (dtp)) { /* Check whether we hit EOF. */ *************** next_char (st_parameter_dt *dtp) *** 235,247 **** } else { ! if (length == 0) { if (dtp->u.p.current_unit->endfile == AT_ENDFILE) longjmp (*dtp->u.p.eof_jump, 1); dtp->u.p.current_unit->endfile = AT_ENDFILE; c = '\n'; } } done: dtp->u.p.at_eol = (c == '\n' || c == '\r'); --- 231,250 ---- } else { ! cc = fbuf_getc (dtp->u.p.current_unit); ! ! if (cc == EOF) { if (dtp->u.p.current_unit->endfile == AT_ENDFILE) longjmp (*dtp->u.p.eof_jump, 1); dtp->u.p.current_unit->endfile = AT_ENDFILE; c = '\n'; } + else + c = (char) cc; + if (is_stream_io (dtp) && cc != EOF) + dtp->u.p.current_unit->strm_pos++; + } done: dtp->u.p.at_eol = (c == '\n' || c == '\r'); *************** parse_real (st_parameter_dt *dtp, void * *** 1216,1222 **** what it is right away. */ static void ! read_complex (st_parameter_dt *dtp, int kind, size_t size) { char message[100]; char c; --- 1219,1225 ---- what it is right away. */ static void ! read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size) { char message[100]; char c; *************** read_complex (st_parameter_dt *dtp, int *** 1240,1246 **** } eat_spaces (dtp); ! if (parse_real (dtp, dtp->u.p.value, kind)) return; eol_1: --- 1243,1249 ---- } eat_spaces (dtp); ! if (parse_real (dtp, dest, kind)) return; eol_1: *************** eol_2: *** 1263,1269 **** else unget_char (dtp, c); ! if (parse_real (dtp, dtp->u.p.value + size / 2, kind)) return; eat_spaces (dtp); --- 1266,1272 ---- else unget_char (dtp, c); ! if (parse_real (dtp, dest + size / 2, kind)) return; eat_spaces (dtp); *************** eol_2: *** 1297,1303 **** /* Parse a real number with a possible repeat count. */ static void ! read_real (st_parameter_dt *dtp, int length) { char c, message[100]; int seen_dp; --- 1300,1306 ---- /* Parse a real number with a possible repeat count. */ static void ! read_real (st_parameter_dt *dtp, void * dest, int length) { char c, message[100]; int seen_dp; *************** read_real (st_parameter_dt *dtp, int len *** 1510,1516 **** unget_char (dtp, c); eat_separator (dtp); push_char (dtp, '\0'); ! if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length)) return; free_saved (dtp); --- 1513,1519 ---- unget_char (dtp, c); eat_separator (dtp); push_char (dtp, '\0'); ! if (convert_real (dtp, dest, dtp->u.p.saved_string, length)) return; free_saved (dtp); *************** list_formatted_read_scalar (st_parameter *** 1684,1689 **** --- 1687,1697 ---- if (setjmp (eof_jump)) { generate_error (&dtp->common, LIBERROR_END, NULL); + if (!is_internal_unit (dtp)) + { + dtp->u.p.current_unit->endfile = AFTER_ENDFILE; + dtp->u.p.current_unit->current_record = 0; + } goto cleanup; } *************** list_formatted_read_scalar (st_parameter *** 1693,1699 **** dtp->u.p.input_complete = 0; dtp->u.p.repeat_count = 1; dtp->u.p.at_eol = 0; ! c = eat_spaces (dtp); if (is_separator (c)) { --- 1701,1707 ---- dtp->u.p.input_complete = 0; dtp->u.p.repeat_count = 1; dtp->u.p.at_eol = 0; ! c = eat_spaces (dtp); if (is_separator (c)) { *************** list_formatted_read_scalar (st_parameter *** 1721,1726 **** --- 1729,1737 ---- return; goto set_value; } + + if (dtp->u.p.input_complete) + goto cleanup; if (dtp->u.p.input_complete) goto cleanup; *************** list_formatted_read_scalar (st_parameter *** 1751,1760 **** read_character (dtp, kind); break; case BT_REAL: ! read_real (dtp, kind); break; case BT_COMPLEX: ! read_complex (dtp, kind, size); break; default: internal_error (&dtp->common, "Bad type for list read"); --- 1762,1777 ---- read_character (dtp, kind); break; case BT_REAL: ! read_real (dtp, p, kind); ! /* Copy value back to temporary if needed. */ ! if (dtp->u.p.repeat_count > 0) ! memcpy (dtp->u.p.value, p, kind); break; case BT_COMPLEX: ! read_complex (dtp, p, kind, size); ! /* Copy value back to temporary if needed. */ ! if (dtp->u.p.repeat_count > 0) ! memcpy (dtp->u.p.value, p, size); break; default: internal_error (&dtp->common, "Bad type for list read"); *************** list_formatted_read_scalar (st_parameter *** 1770,1777 **** switch (dtp->u.p.saved_type) { case BT_COMPLEX: - case BT_INTEGER: case BT_REAL: case BT_LOGICAL: memcpy (p, dtp->u.p.value, size); break; --- 1787,1798 ---- switch (dtp->u.p.saved_type) { case BT_COMPLEX: case BT_REAL: + if (dtp->u.p.repeat_count > 0) + memcpy (p, dtp->u.p.value, size); + break; + + case BT_INTEGER: case BT_LOGICAL: memcpy (p, dtp->u.p.value, size); break; *************** finish_list_read (st_parameter_dt *dtp) *** 1848,1853 **** --- 1869,1876 ---- free_saved (dtp); + fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); + if (dtp->u.p.at_eol) { dtp->u.p.at_eol = 0; *************** nml_query (st_parameter_dt *dtp, char c) *** 2256,2263 **** /* Flush the stream to force immediate output. */ ! fbuf_flush (dtp->u.p.current_unit, 1); ! flush (dtp->u.p.current_unit->s); unlock_unit (dtp->u.p.current_unit); } --- 2279,2286 ---- /* Flush the stream to force immediate output. */ ! fbuf_flush (dtp->u.p.current_unit, WRITING); ! sflush (dtp->u.p.current_unit->s); unlock_unit (dtp->u.p.current_unit); } *************** nml_read_obj (st_parameter_dt *dtp, name *** 2292,2298 **** int dim; index_type dlen; index_type m; ! index_type obj_name_len; void * pdata; /* This object not touched in name parsing. */ --- 2315,2321 ---- int dim; index_type dlen; index_type m; ! size_t obj_name_len; void * pdata; /* This object not touched in name parsing. */ *************** nml_read_obj (st_parameter_dt *dtp, name *** 2371,2382 **** break; case GFC_DTYPE_REAL: ! read_real (dtp, len); ! break; case GFC_DTYPE_COMPLEX: ! read_complex (dtp, len, dlen); ! break; case GFC_DTYPE_DERIVED: obj_name_len = strlen (nl->var_name) + 1; --- 2394,2410 ---- break; case GFC_DTYPE_REAL: ! /* Need to copy data back from the real location to the temp in order ! to handle nml reads into arrays. */ ! read_real (dtp, pdata, len); ! memcpy (dtp->u.p.value, pdata, dlen); ! break; case GFC_DTYPE_COMPLEX: ! /* Same as for REAL, copy back to temp. */ ! read_complex (dtp, pdata, len, dlen); ! memcpy (dtp->u.p.value, pdata, dlen); ! break; case GFC_DTYPE_DERIVED: obj_name_len = strlen (nl->var_name) + 1; *************** find_nml_name: *** 2898,2904 **** st_printf ("%s\n", nml_err_msg); if (u != NULL) { ! flush (u->s); unlock_unit (u); } } --- 2926,2932 ---- st_printf ("%s\n", nml_err_msg); if (u != NULL) { ! sflush (u->s); unlock_unit (u); } } diff -Nrcpad gcc-4.4.0/libgfortran/io/open.c gcc-4.4.1/libgfortran/io/open.c *** gcc-4.4.0/libgfortran/io/open.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/open.c Sun Jul 19 23:10:22 2009 *************** static const st_option async_opt[] = *** 150,156 **** static void test_endfile (gfc_unit * u) { ! if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s)) u->endfile = AT_ENDFILE; } --- 150,156 ---- static void test_endfile (gfc_unit * u) { ! if (u->endfile == NO_ENDFILE && file_length (u->s) == stell (u->s)) u->endfile = AT_ENDFILE; } *************** edit_modes (st_parameter_open *opp, gfc_ *** 266,272 **** break; case POSITION_REWIND: ! if (sseek (u->s, 0) == FAILURE) goto seek_error; u->current_record = 0; --- 266,272 ---- break; case POSITION_REWIND: ! if (sseek (u->s, 0, SEEK_SET) != 0) goto seek_error; u->current_record = 0; *************** edit_modes (st_parameter_open *opp, gfc_ *** 276,282 **** break; case POSITION_APPEND: ! if (sseek (u->s, file_length (u->s)) == FAILURE) goto seek_error; if (flags->access != ACCESS_STREAM) --- 276,282 ---- break; case POSITION_APPEND: ! if (sseek (u->s, 0, SEEK_END) < 0) goto seek_error; if (flags->access != ACCESS_STREAM) *************** new_unit (st_parameter_open *opp, gfc_un *** 552,558 **** if (flags->position == POSITION_APPEND) { ! if (sseek (u->s, file_length (u->s)) == FAILURE) generate_error (&opp->common, LIBERROR_OS, NULL); u->endfile = AT_ENDFILE; } --- 552,558 ---- if (flags->position == POSITION_APPEND) { ! if (sseek (u->s, 0, SEEK_END) < 0) generate_error (&opp->common, LIBERROR_OS, NULL); u->endfile = AT_ENDFILE; } *************** new_unit (st_parameter_open *opp, gfc_un *** 606,612 **** { u->maxrec = max_offset; u->recl = 1; ! u->strm_pos = file_position (u->s) + 1; } memmove (u->file, opp->file, opp->file_len); --- 606,613 ---- { u->maxrec = max_offset; u->recl = 1; ! u->bytes_left = 1; ! u->strm_pos = stell (u->s) + 1; } memmove (u->file, opp->file, opp->file_len); *************** new_unit (st_parameter_open *opp, gfc_un *** 622,628 **** if (flags->status == STATUS_SCRATCH && opp->file != NULL) free_mem (opp->file); ! if (flags->form == FORM_FORMATTED && (flags->action != ACTION_READ)) { if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)) fbuf_init (u, u->recl); --- 623,629 ---- if (flags->status == STATUS_SCRATCH && opp->file != NULL) free_mem (opp->file); ! if (flags->form == FORM_FORMATTED) { if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)) fbuf_init (u, u->recl); *************** already_open (st_parameter_open *opp, gf *** 676,682 **** } #endif ! if (sclose (u->s) == FAILURE) { unlock_unit (u); generate_error (&opp->common, LIBERROR_OS, --- 677,683 ---- } #endif ! if (sclose (u->s) == -1) { unlock_unit (u); generate_error (&opp->common, LIBERROR_OS, *************** st_open (st_parameter_open *opp) *** 774,780 **** find_option (&opp->common, opp->status, opp->status_len, status_opt, "Bad STATUS parameter in OPEN statement"); ! /* First, we check wether the convert flag has been set via environment variable. This overrides the convert tag in the open statement. */ conv = get_unformatted_convert (opp->common.unit); --- 775,781 ---- find_option (&opp->common, opp->status, opp->status_len, status_opt, "Bad STATUS parameter in OPEN statement"); ! /* First, we check whether the convert flag has been set via environment variable. This overrides the convert tag in the open statement. */ conv = get_unformatted_convert (opp->common.unit); diff -Nrcpad gcc-4.4.0/libgfortran/io/read.c gcc-4.4.1/libgfortran/io/read.c *** gcc-4.4.0/libgfortran/io/read.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/read.c Wed May 27 01:21:22 2009 *************** see the files COPYING3 and COPYING.RUNTI *** 28,33 **** --- 28,34 ---- #include #include #include + #include typedef unsigned char uchar; *************** max_value (int length, int signed_flag) *** 125,132 **** /* convert_real()-- Convert a character representation of a floating * point number to the machine number. Returns nonzero if there is a ! * range problem during conversion. TODO: handle not-a-numbers and ! * infinities. */ int convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length) --- 126,135 ---- /* convert_real()-- Convert a character representation of a floating * point number to the machine number. Returns nonzero if there is a ! * range problem during conversion. Note: many architectures ! * (e.g. IA-64, HP-PA) require that the storage pointed to by the dest ! * argument is properly aligned for the type in question. TODO: ! * handle not-a-numbers and infinities. */ int convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length) *************** convert_real (st_parameter_dt *dtp, void *** 136,173 **** switch (length) { case 4: ! { ! GFC_REAL_4 tmp = #if defined(HAVE_STRTOF) ! strtof (buffer, NULL); #else ! (GFC_REAL_4) strtod (buffer, NULL); #endif - memcpy (dest, (void *) &tmp, length); - } break; case 8: ! { ! GFC_REAL_8 tmp = strtod (buffer, NULL); ! memcpy (dest, (void *) &tmp, length); ! } break; #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD) case 10: ! { ! GFC_REAL_10 tmp = strtold (buffer, NULL); ! memcpy (dest, (void *) &tmp, length); ! } break; #endif #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD) case 16: ! { ! GFC_REAL_16 tmp = strtold (buffer, NULL); ! memcpy (dest, (void *) &tmp, length); ! } break; #endif default: internal_error (&dtp->common, "Unsupported real kind during IO"); } --- 139,168 ---- switch (length) { case 4: ! *((GFC_REAL_4*) dest) = #if defined(HAVE_STRTOF) ! strtof (buffer, NULL); #else ! (GFC_REAL_4) strtod (buffer, NULL); #endif break; + case 8: ! *((GFC_REAL_8*) dest) = strtod (buffer, NULL); break; + #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD) case 10: ! *((GFC_REAL_10*) dest) = strtold (buffer, NULL); break; #endif + #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD) case 16: ! *((GFC_REAL_16*) dest) = strtold (buffer, NULL); break; #endif + default: internal_error (&dtp->common, "Unsupported real kind during IO"); } *************** void *** 190,202 **** read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { char *p; ! size_t w; w = f->u.w; ! p = gfc_alloca (w); ! if (read_block_form (dtp, p, &w) == FAILURE) return; while (*p == ' ') --- 185,197 ---- read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { char *p; ! int w; w = f->u.w; ! p = read_block_form (dtp, &w); ! if (p == NULL) return; while (*p == ' ') *************** read_l (st_parameter_dt *dtp, const fnod *** 233,260 **** } ! static inline gfc_char4_t ! read_utf8 (st_parameter_dt *dtp, size_t *nbytes) { static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 }; static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; ! static uchar buffer[6]; ! size_t i, nb, nread; gfc_char4_t c; - int status; char *s; *nbytes = 1; ! s = (char *) &buffer[0]; ! status = read_block_form (dtp, s, nbytes); ! if (status == FAILURE) return 0; /* If this is a short read, just return. */ if (*nbytes == 0) return 0; ! c = buffer[0]; if (c < 0x80) return c; --- 228,253 ---- } ! static gfc_char4_t ! read_utf8 (st_parameter_dt *dtp, int *nbytes) { static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 }; static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; ! int i, nb, nread; gfc_char4_t c; char *s; *nbytes = 1; ! ! s = read_block_form (dtp, nbytes); ! if (s == NULL) return 0; /* If this is a short read, just return. */ if (*nbytes == 0) return 0; ! c = (uchar) s[0]; if (c < 0x80) return c; *************** read_utf8 (st_parameter_dt *dtp, size_t *** 269,277 **** c = (c & masks[nb-1]); nread = nb - 1; ! s = (char *) &buffer[1]; ! status = read_block_form (dtp, s, &nread); ! if (status == FAILURE) return 0; /* Decode the bytes read. */ for (i = 1; i < nb; i++) --- 262,269 ---- c = (c & masks[nb-1]); nread = nb - 1; ! s = read_block_form (dtp, &nread); ! if (s == NULL) return 0; /* Decode the bytes read. */ for (i = 1; i < nb; i++) *************** read_utf8 (st_parameter_dt *dtp, size_t *** 304,317 **** static void ! read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, size_t width) { gfc_char4_t c; char *dest; ! size_t nbytes; int i, j; ! len = ((int) width < len) ? len : (int) width; dest = (char *) p; --- 296,309 ---- static void ! read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width) { gfc_char4_t c; char *dest; ! int nbytes; int i, j; ! len = (width < len) ? len : width; dest = (char *) p; *************** read_utf8_char1 (st_parameter_dt *dtp, c *** 334,354 **** } static void ! read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t width) { char *s; ! int m, n, status; ! ! s = gfc_alloca (width); ! status = read_block_form (dtp, s, &width); ! if (status == FAILURE) return; ! if (width > (size_t) len) s += (width - len); ! m = ((int) width > len) ? len : (int) width; memcpy (p, s, m); n = len - width; --- 326,344 ---- } static void ! read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width) { char *s; ! int m, n; ! s = read_block_form (dtp, &width); ! if (s == NULL) return; ! if (width > len) s += (width - len); ! m = (width > len) ? len : width; memcpy (p, s, m); n = len - width; *************** read_default_char1 (st_parameter_dt *dtp *** 358,370 **** static void ! read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, size_t width) { gfc_char4_t *dest; ! size_t nbytes; int i, j; ! len = ((int) width < len) ? len : (int) width; dest = (gfc_char4_t *) p; --- 348,360 ---- static void ! read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width) { gfc_char4_t *dest; ! int nbytes; int i, j; ! len = (width < len) ? len : width; dest = (gfc_char4_t *) p; *************** read_utf8_char4 (st_parameter_dt *dtp, v *** 386,404 **** static void ! read_default_char4 (st_parameter_dt *dtp, char *p, int len, size_t width) { char *s; gfc_char4_t *dest; ! int m, n, status; ! ! s = gfc_alloca (width); ! status = read_block_form (dtp, s, &width); ! if (status == FAILURE) return; ! if (width > (size_t) len) s += (width - len); m = ((int) width > len) ? len : (int) width; --- 376,392 ---- static void ! read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width) { char *s; gfc_char4_t *dest; ! int m, n; ! s = read_block_form (dtp, &width); ! if (s == NULL) return; ! if (width > len) s += (width - len); m = ((int) width > len) ? len : (int) width; *************** void *** 420,426 **** read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length) { int wi; ! size_t w; wi = f->u.w; if (wi == -1) /* '(A)' edit descriptor */ --- 408,414 ---- read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length) { int wi; ! int w; wi = f->u.w; if (wi == -1) /* '(A)' edit descriptor */ *************** read_a (st_parameter_dt *dtp, const fnod *** 446,458 **** void read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length) { ! int wi; ! size_t w; ! wi = f->u.w; ! if (wi == -1) /* '(A)' edit descriptor */ ! wi = length; ! w = wi; /* Read in w characters, treating comma as not a separator. */ dtp->u.p.sf_read_comma = 0; --- 434,444 ---- void read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length) { ! int w; ! w = f->u.w; ! if (w == -1) /* '(A)' edit descriptor */ ! w = length; /* Read in w characters, treating comma as not a separator. */ dtp->u.p.sf_read_comma = 0; *************** read_decimal (st_parameter_dt *dtp, cons *** 527,544 **** GFC_UINTEGER_LARGEST value, maxv, maxv_10; GFC_INTEGER_LARGEST v; int w, negative; - size_t wu; char c, *p; ! wu = f->u.w; ! p = gfc_alloca (wu); ! if (read_block_form (dtp, p, &wu) == FAILURE) return; - w = wu; - p = eat_leading_spaces (&w, p); if (w == 0) { --- 513,527 ---- GFC_UINTEGER_LARGEST value, maxv, maxv_10; GFC_INTEGER_LARGEST v; int w, negative; char c, *p; ! w = f->u.w; ! p = read_block_form (dtp, &w); ! if (p == NULL) return; p = eat_leading_spaces (&w, p); if (w == 0) { *************** read_radix (st_parameter_dt *dtp, const *** 631,647 **** GFC_INTEGER_LARGEST v; int w, negative; char c, *p; - size_t wu; ! wu = f->u.w; ! p = gfc_alloca (wu); ! if (read_block_form (dtp, p, &wu) == FAILURE) return; - w = wu; - p = eat_leading_spaces (&w, p); if (w == 0) { --- 614,627 ---- GFC_INTEGER_LARGEST v; int w, negative; char c, *p; ! w = f->u.w; ! p = read_block_form (dtp, &w); ! if (p == NULL) return; p = eat_leading_spaces (&w, p); if (w == 0) { *************** read_radix (st_parameter_dt *dtp, const *** 778,852 **** void read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { - size_t wu; int w, seen_dp, exponent; ! int exponent_sign, val_sign; ! int ndigits; ! int edigits; ! int i; ! char *p, *buffer; ! char *digits; ! char scratch[SCRATCH_SIZE]; - val_sign = 1; seen_dp = 0; ! wu = f->u.w; ! ! p = gfc_alloca (wu); ! if (read_block_form (dtp, p, &wu) == FAILURE) return; ! ! w = wu; ! ! p = eat_leading_spaces (&w, p); if (w == 0) goto zero; ! /* Optional sign */ if (*p == '-' || *p == '+') { if (*p == '-') ! val_sign = -1; ! p++; ! w--; } ! exponent_sign = 1; ! p = eat_leading_spaces (&w, p); if (w == 0) goto zero; ! /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D') ! is required at this point */ ! ! if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D' ! && *p != 'e' && *p != 'E') ! goto bad_float; ! ! /* Remember the position of the first digit. */ ! digits = p; ! ndigits = 0; ! ! /* Scan through the string to find the exponent. */ while (w > 0) { switch (*p) { case ',': ! if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ! && *p == ',') ! *p = '.'; ! else goto bad_float; ! /* Fall through */ case '.': if (seen_dp) goto bad_float; seen_dp = 1; ! /* Fall through */ case '0': case '1': case '2': --- 758,840 ---- void read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { int w, seen_dp, exponent; ! int exponent_sign; ! const char *p; ! char *buffer; ! char *out; ! int seen_int_digit; /* Seen a digit before the decimal point? */ ! int seen_dec_digit; /* Seen a digit after the decimal point? */ seen_dp = 0; ! seen_int_digit = 0; ! seen_dec_digit = 0; ! exponent_sign = 1; ! exponent = 0; ! w = f->u.w; ! /* Read in the next block. */ ! p = read_block_form (dtp, &w); ! if (p == NULL) return; ! p = eat_leading_spaces (&w, (char*) p); if (w == 0) goto zero; ! /* In this buffer we're going to re-format the number cleanly to be parsed ! by convert_real in the end; this assures we're using strtod from the ! C library for parsing and thus probably get the best accuracy possible. ! This process may add a '+0.0' in front of the number as well as change the ! exponent because of an implicit decimal point or the like. Thus allocating ! strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the ! original buffer had should be enough. */ ! buffer = gfc_alloca (w + 11); ! out = buffer; + /* Optional sign */ if (*p == '-' || *p == '+') { if (*p == '-') ! *(out++) = '-'; ! ++p; ! --w; } ! p = eat_leading_spaces (&w, (char*) p); if (w == 0) goto zero; ! /* Process the mantissa string. */ while (w > 0) { switch (*p) { case ',': ! if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA) goto bad_float; ! /* Fall through. */ case '.': if (seen_dp) goto bad_float; + if (!seen_int_digit) + *(out++) = '0'; + *(out++) = '.'; seen_dp = 1; ! break; + case ' ': + if (dtp->u.p.blank_status == BLANK_ZERO) + { + *(out++) = '0'; + goto found_digit; + } + else if (dtp->u.p.blank_status == BLANK_NULL) + break; + else + /* TODO: Should we check instead that there are only trailing + blanks here, as is done below for exponents? */ + goto done; + /* Fall through. */ case '0': case '1': case '2': *************** read_f (st_parameter_dt *dtp, const fnod *** 857,1063 **** case '7': case '8': case '9': ! case ' ': ! ndigits++; ! p++; ! w--; break; case '-': - exponent_sign = -1; - /* Fall through */ - case '+': ! p++; ! w--; ! goto exp2; - case 'd': case 'e': - case 'D': case 'E': ! p++; ! w--; ! goto exp1; default: goto bad_float; } - } - - /* No exponent has been seen, so we use the current scale factor */ - exponent = -dtp->u.p.scale_factor; - goto done; - - bad_float: - generate_error (&dtp->common, LIBERROR_READ_VALUE, - "Bad value during floating point read"); - next_record (dtp, 1); - return; - - /* The value read is zero */ - zero: - switch (length) - { - case 4: - *((GFC_REAL_4 *) dest) = 0; - break; - - case 8: - *((GFC_REAL_8 *) dest) = 0; - break; - - #ifdef HAVE_GFC_REAL_10 - case 10: - *((GFC_REAL_10 *) dest) = 0; - break; - #endif - - #ifdef HAVE_GFC_REAL_16 - case 16: - *((GFC_REAL_16 *) dest) = 0; - break; - #endif ! default: ! internal_error (&dtp->common, "Unsupported real kind during IO"); } ! return; ! /* At this point the start of an exponent has been found */ ! exp1: ! while (w > 0 && *p == ' ') { ! w--; ! p++; } ! switch (*p) ! { ! case '-': ! exponent_sign = -1; ! /* Fall through */ ! ! case '+': ! p++; ! w--; ! break; ! } if (w == 0) goto bad_float; - /* At this point a digit string is required. We calculate the value - of the exponent in order to take account of the scale factor and - the d parameter before explict conversion takes place. */ - exp2: - /* Normal processing of exponent */ - exponent = 0; if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) { 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 (dtp->u.p.blank_status == BLANK_ZERO) *p = '0'; ! if (dtp->u.p.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; ! done: /* Use the precision specified in the format if no decimal point has been seen. */ if (!seen_dp) exponent -= f->u.real.d; ! if (exponent > 0) ! { ! edigits = 2; ! i = exponent; ! } ! else ! { ! edigits = 3; ! i = -exponent; ! } ! while (i >= 10) { ! i /= 10; ! edigits++; ! } ! ! i = ndigits + edigits + 1; ! if (val_sign < 0) ! i++; ! if (i < SCRATCH_SIZE) ! buffer = scratch; ! else ! 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 (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0'; ! if (dtp->u.p.blank_status == BLANK_NULL) ! { ! digits++; ! continue; ! } ! } ! *p = *digits; ! p++; ! digits++; } ! *(p++) = 'e'; ! sprintf (p, "%d", exponent); /* Do the actual conversion. */ convert_real (dtp, dest, buffer, length); ! if (buffer != scratch) ! free_mem (buffer); } --- 845,1017 ---- case '7': case '8': case '9': ! *(out++) = *p; ! found_digit: ! if (!seen_dp) ! seen_int_digit = 1; ! else ! seen_dec_digit = 1; break; case '-': case '+': ! goto exponent; case 'e': case 'E': ! case 'd': ! case 'D': ! ++p; ! --w; ! goto exponent; default: goto bad_float; } ! ++p; ! --w; } ! ! /* No exponent has been seen, so we use the current scale factor. */ ! exponent = - dtp->u.p.scale_factor; ! goto done; ! /* At this point the start of an exponent has been found. */ ! exponent: ! p = eat_leading_spaces (&w, (char*) p); ! if (*p == '-' || *p == '+') { ! if (*p == '-') ! exponent_sign = -1; ! ++p; ! --w; } ! /* At this point a digit string is required. We calculate the value ! of the exponent in order to take account of the scale factor and ! the d parameter before explict conversion takes place. */ if (w == 0) goto bad_float; if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) { 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 (dtp->u.p.blank_status == BLANK_ZERO) ! exponent *= 10; ! else ! assert (dtp->u.p.blank_status == BLANK_NULL); ! } ! else if (!isdigit (*p)) ! goto bad_float; ! else ! { ! exponent *= 10; ! exponent += *p - '0'; ! } ! ++p; ! --w; ! } } ! exponent *= exponent_sign; ! done: /* Use the precision specified in the format if no decimal point has been seen. */ if (!seen_dp) exponent -= f->u.real.d; ! /* Output a trailing '0' after decimal point if not yet found. */ ! if (seen_dp && !seen_dec_digit) ! *(out++) = '0'; ! /* Print out the exponent to finish the reformatted number. Maximum 4 ! digits for the exponent. */ ! if (exponent != 0) { ! int dig; ! *(out++) = 'e'; ! if (exponent < 0) ! { ! *(out++) = '-'; ! exponent = - exponent; ! } ! assert (exponent < 10000); ! for (dig = 3; dig >= 0; --dig) ! { ! out[dig] = (char) ('0' + exponent % 10); ! exponent /= 10; ! } ! out += 4; } ! *(out++) = '\0'; /* Do the actual conversion. */ convert_real (dtp, dest, buffer, length); ! return; + /* The value read is zero. */ + zero: + switch (length) + { + case 4: + *((GFC_REAL_4 *) dest) = 0.0; + break; + + case 8: + *((GFC_REAL_8 *) dest) = 0.0; + break; + + #ifdef HAVE_GFC_REAL_10 + case 10: + *((GFC_REAL_10 *) dest) = 0.0; + break; + #endif + + #ifdef HAVE_GFC_REAL_16 + case 16: + *((GFC_REAL_16 *) dest) = 0.0; + break; + #endif + + default: + internal_error (&dtp->common, "Unsupported real kind during IO"); + } + return; + + bad_float: + generate_error (&dtp->common, LIBERROR_READ_VALUE, + "Bad value during floating point read"); + next_record (dtp, 1); + return; } diff -Nrcpad gcc-4.4.0/libgfortran/io/transfer.c gcc-4.4.1/libgfortran/io/transfer.c *** gcc-4.4.0/libgfortran/io/transfer.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/transfer.c Sun Jul 19 23:10:22 2009 *************** see the files COPYING3 and COPYING.RUNTI *** 32,37 **** --- 32,38 ---- #include #include #include + #include /* Calling conventions: Data transfer statements are unlike other *************** current_mode (st_parameter_dt *dtp) *** 178,237 **** heap. Hopefully this won't happen very often. */ char * ! read_sf (st_parameter_dt *dtp, int *length, int no_error) { char *base, *p, q; ! int n, crlf; ! gfc_offset pos; ! size_t readlen; ! if (*length > SCRATCH_SIZE) ! dtp->u.p.line_buffer = get_mem (*length); ! p = base = dtp->u.p.line_buffer; /* If we have seen an eor previously, return a length of 0. The caller is responsible for correctly padding the input field. */ if (dtp->u.p.sf_seen_eor) { *length = 0; ! return base; } if (is_internal_unit (dtp)) { ! readlen = *length; ! if (unlikely (sread (dtp->u.p.current_unit->s, p, &readlen) != 0 ! || readlen < (size_t) *length)) { ! generate_error (&dtp->common, LIBERROR_END, NULL); return NULL; } ! goto done; } ! readlen = 1; ! n = 0; ! do ! { ! if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0)) ! { ! generate_error (&dtp->common, LIBERROR_END, NULL); ! return NULL; ! } ! /* If we have a line without a terminating \n, drop through to ! EOR below. */ ! if (readlen < 1 && n == 0) ! { ! if (likely (no_error)) ! break; ! generate_error (&dtp->common, LIBERROR_END, NULL); ! return NULL; ! } ! if (readlen < 1 || q == '\n' || q == '\r') { /* Unexpected end of line. */ --- 179,236 ---- heap. Hopefully this won't happen very often. */ char * ! read_sf (st_parameter_dt *dtp, int * length, int no_error) { + static char *empty_string[0]; char *base, *p, q; ! int n, lorig, memread, seen_comma; ! /* If we hit EOF previously with the no_error flag set (i.e. X, T, ! TR edit descriptors), and we now try to read again, this time ! without setting no_error. */ ! if (!no_error && dtp->u.p.at_eof) ! { ! *length = 0; ! hit_eof (dtp); ! return NULL; ! } /* If we have seen an eor previously, return a length of 0. The caller is responsible for correctly padding the input field. */ if (dtp->u.p.sf_seen_eor) { *length = 0; ! /* Just return something that isn't a NULL pointer, otherwise the ! caller thinks an error occured. */ ! return (char*) empty_string; } if (is_internal_unit (dtp)) { ! memread = *length; ! base = mem_alloc_r (dtp->u.p.current_unit->s, length); ! if (unlikely (memread > *length)) { ! hit_eof (dtp); return NULL; } ! n = *length; goto done; } ! n = seen_comma = 0; ! /* Read data into format buffer and scan through it. */ ! lorig = *length; ! base = p = fbuf_read (dtp->u.p.current_unit, length); ! if (base == NULL) ! return NULL; ! while (n < *length) ! { ! q = *p; ! if (q == '\n' || q == '\r') { /* Unexpected end of line. */ *************** read_sf (st_parameter_dt *dtp, int *leng *** 240,262 **** if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) dtp->u.p.eor_condition = 1; - crlf = 0; /* If we encounter a CR, it might be a CRLF. */ if (q == '\r') /* Probably a CRLF */ { ! readlen = 1; ! pos = stream_offset (dtp->u.p.current_unit->s); ! if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen) ! != 0)) ! { ! generate_error (&dtp->common, LIBERROR_END, NULL); ! return NULL; ! } ! if (q != '\n' && readlen == 1) /* Not a CRLF after all. */ ! sseek (dtp->u.p.current_unit->s, pos); ! else ! crlf = 1; } /* Without padding, terminate the I/O statement without assigning the value. With padding, the value still needs to be assigned, --- 239,252 ---- if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) dtp->u.p.eor_condition = 1; /* If we encounter a CR, it might be a CRLF. */ if (q == '\r') /* Probably a CRLF */ { ! if (n < *length && *(p + 1) == '\n') ! dtp->u.p.sf_seen_eor = 2; } + else + dtp->u.p.sf_seen_eor = 1; /* Without padding, terminate the I/O statement without assigning the value. With padding, the value still needs to be assigned, *************** read_sf (st_parameter_dt *dtp, int *leng *** 270,276 **** } *length = n; - dtp->u.p.sf_seen_eor = (crlf ? 2 : 1); break; } /* Short circuit the read if a comma is found during numeric input. --- 260,265 ---- *************** read_sf (st_parameter_dt *dtp, int *leng *** 279,284 **** --- 268,274 ---- if (q == ',') if (dtp->u.p.sf_read_comma == 1) { + seen_comma = 1; notify_std (&dtp->common, GFC_STD_GNU, "Comma in formatted numeric read."); *length = n; *************** read_sf (st_parameter_dt *dtp, int *leng *** 286,301 **** } n++; ! *p++ = q; ! dtp->u.p.sf_seen_eor = 0; } - while (n < *length); done: ! dtp->u.p.current_unit->bytes_left -= *length; if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ! dtp->u.p.size_used += (GFC_IO_INT) *length; return base; } --- 276,306 ---- } n++; ! p++; ! } ! ! fbuf_seek (dtp->u.p.current_unit, n + dtp->u.p.sf_seen_eor + seen_comma, ! SEEK_CUR); ! ! /* A short read implies we hit EOF, unless we hit EOR, a comma, or ! some other stuff. Set the relevant flags. */ ! if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma) ! { ! if (no_error) ! dtp->u.p.at_eof = 1; ! else ! { ! hit_eof (dtp); ! return NULL; ! } } done: ! ! dtp->u.p.current_unit->bytes_left -= n; if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ! dtp->u.p.size_used += (GFC_IO_INT) n; return base; } *************** read_sf (st_parameter_dt *dtp, int *leng *** 311,322 **** opened with PAD=YES. The caller must assume tailing spaces for short reads. */ ! try ! read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes) { char *source; ! size_t nread; ! int nb; if (!is_stream_io (dtp)) { --- 316,326 ---- opened with PAD=YES. The caller must assume tailing spaces for short reads. */ ! void * ! read_block_form (st_parameter_dt *dtp, int * nbytes) { char *source; ! int norig; if (!is_stream_io (dtp)) { *************** read_block_form (st_parameter_dt *dtp, v *** 333,347 **** { /* Not enough data left. */ generate_error (&dtp->common, LIBERROR_EOR, NULL); ! return FAILURE; } } if (unlikely (dtp->u.p.current_unit->bytes_left == 0)) { ! dtp->u.p.current_unit->endfile = AT_ENDFILE; ! generate_error (&dtp->common, LIBERROR_END, NULL); ! return FAILURE; } *nbytes = dtp->u.p.current_unit->bytes_left; --- 337,350 ---- { /* Not enough data left. */ generate_error (&dtp->common, LIBERROR_EOR, NULL); ! return NULL; } } if (unlikely (dtp->u.p.current_unit->bytes_left == 0)) { ! hit_eof (dtp); ! return NULL; } *nbytes = dtp->u.p.current_unit->bytes_left; *************** read_block_form (st_parameter_dt *dtp, v *** 352,393 **** (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL || dtp->u.p.current_unit->flags.access == ACCESS_STREAM)) { ! nb = *nbytes; ! source = read_sf (dtp, &nb, 0); ! *nbytes = nb; dtp->u.p.current_unit->strm_pos += (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor); ! if (source == NULL) ! return FAILURE; ! memcpy (buf, source, *nbytes); ! return SUCCESS; } dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes; ! nread = *nbytes; ! if (unlikely (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)) ! { ! generate_error (&dtp->common, LIBERROR_OS, NULL); ! return FAILURE; ! } if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ! dtp->u.p.size_used += (GFC_IO_INT) nread; ! if (nread != *nbytes) ! { /* Short read, this shouldn't happen. */ ! if (likely (dtp->u.p.current_unit->pad_status == PAD_YES)) ! *nbytes = nread; ! else { generate_error (&dtp->common, LIBERROR_EOR, NULL); source = NULL; } } ! dtp->u.p.current_unit->strm_pos += (gfc_offset) nread; ! return SUCCESS; } --- 355,390 ---- (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL || dtp->u.p.current_unit->flags.access == ACCESS_STREAM)) { ! source = read_sf (dtp, nbytes, 0); dtp->u.p.current_unit->strm_pos += (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor); ! return source; } + + /* If we reach here, we can assume it's direct access. */ + dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes; ! norig = *nbytes; ! source = fbuf_read (dtp->u.p.current_unit, nbytes); ! fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR); if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ! dtp->u.p.size_used += (GFC_IO_INT) *nbytes; ! if (norig != *nbytes) ! { ! /* Short read, this shouldn't happen. */ ! if (!dtp->u.p.current_unit->pad_status == PAD_YES) { generate_error (&dtp->common, LIBERROR_EOR, NULL); source = NULL; } } ! dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes; ! return source; } *************** read_block_form (st_parameter_dt *dtp, v *** 395,414 **** unformatted files. */ static void ! read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) { ! size_t to_read_record; ! size_t have_read_record; ! size_t to_read_subrecord; ! size_t have_read_subrecord; int short_record; if (is_stream_io (dtp)) { ! to_read_record = *nbytes; ! have_read_record = to_read_record; ! if (unlikely (sread (dtp->u.p.current_unit->s, buf, &have_read_record) ! != 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; --- 392,410 ---- unformatted files. */ static void ! read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes) { ! ssize_t to_read_record; ! ssize_t have_read_record; ! ssize_t to_read_subrecord; ! ssize_t have_read_subrecord; int short_record; if (is_stream_io (dtp)) { ! have_read_record = sread (dtp->u.p.current_unit->s, buf, ! nbytes); ! if (unlikely (have_read_record < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; *************** read_block_direct (st_parameter_dt *dtp, *** 416,467 **** dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; ! if (unlikely (to_read_record != have_read_record)) { /* Short read, e.g. if we hit EOF. For stream files, we have to set the end-of-file condition. */ ! generate_error (&dtp->common, LIBERROR_END, NULL); ! return; } return; } if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { ! if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) { short_record = 1; ! to_read_record = (size_t) dtp->u.p.current_unit->bytes_left; ! *nbytes = to_read_record; } - else { short_record = 0; ! to_read_record = *nbytes; } dtp->u.p.current_unit->bytes_left -= to_read_record; ! if (unlikely (sread (dtp->u.p.current_unit->s, buf, &to_read_record) ! != 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } ! if (to_read_record != *nbytes) { /* Short read, e.g. if we hit EOF. Apparently, we read more than was written to the last record. */ - *nbytes = to_read_record; return; } if (unlikely (short_record)) { generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); - return; } return; } --- 412,459 ---- dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; ! if (unlikely ((ssize_t) nbytes != have_read_record)) { /* Short read, e.g. if we hit EOF. For stream files, we have to set the end-of-file condition. */ ! hit_eof (dtp); } return; } if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { ! if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes) { short_record = 1; ! to_read_record = dtp->u.p.current_unit->bytes_left; ! nbytes = to_read_record; } else { short_record = 0; ! to_read_record = nbytes; } dtp->u.p.current_unit->bytes_left -= to_read_record; ! to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record); ! if (unlikely (to_read_record < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } ! if (to_read_record != (ssize_t) nbytes) { /* Short read, e.g. if we hit EOF. Apparently, we read more than was written to the last record. */ return; } if (unlikely (short_record)) { generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); } return; } *************** read_block_direct (st_parameter_dt *dtp, *** 470,492 **** until the request has been fulfilled or the record has run out of continuation subrecords. */ - if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE)) - { - generate_error (&dtp->common, LIBERROR_END, NULL); - return; - } - /* Check whether we exceed the total record length. */ if (dtp->u.p.current_unit->flags.has_recl ! && (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left)) { ! to_read_record = (size_t) dtp->u.p.current_unit->bytes_left; short_record = 1; } else { ! to_read_record = *nbytes; short_record = 0; } have_read_record = 0; --- 462,478 ---- until the request has been fulfilled or the record has run out of continuation subrecords. */ /* Check whether we exceed the total record length. */ if (dtp->u.p.current_unit->flags.has_recl ! && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)) { ! to_read_record = dtp->u.p.current_unit->bytes_left; short_record = 1; } else { ! to_read_record = nbytes; short_record = 0; } have_read_record = 0; *************** read_block_direct (st_parameter_dt *dtp, *** 496,502 **** if (dtp->u.p.current_unit->bytes_left_subrecord < (gfc_offset) to_read_record) { ! to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord; to_read_record -= to_read_subrecord; } else --- 482,488 ---- if (dtp->u.p.current_unit->bytes_left_subrecord < (gfc_offset) to_read_record) { ! to_read_subrecord = dtp->u.p.current_unit->bytes_left_subrecord; to_read_record -= to_read_subrecord; } else *************** read_block_direct (st_parameter_dt *dtp, *** 507,515 **** dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord; ! have_read_subrecord = to_read_subrecord; ! if (unlikely (sread (dtp->u.p.current_unit->s, buf + have_read_record, ! &have_read_subrecord) != 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; --- 493,501 ---- dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord; ! have_read_subrecord = sread (dtp->u.p.current_unit->s, ! buf + have_read_record, to_read_subrecord); ! if (unlikely (have_read_subrecord) < 0) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; *************** read_block_direct (st_parameter_dt *dtp, *** 524,530 **** structure has been corrupted, or the trailing record marker would still be present. */ - *nbytes = have_read_record; generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL); return; } --- 510,515 ---- *************** write_block (st_parameter_dt *dtp, int l *** 598,604 **** if (is_internal_unit (dtp)) { ! dest = salloc_w (dtp->u.p.current_unit->s, &length); if (dest == NULL) { --- 583,589 ---- if (is_internal_unit (dtp)) { ! dest = mem_alloc_w (dtp->u.p.current_unit->s, &length); if (dest == NULL) { *************** static try *** 636,655 **** write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) { ! size_t have_written, to_write_subrecord; int short_record; /* Stream I/O. */ if (is_stream_io (dtp)) { ! if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } ! dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes; return SUCCESS; } --- 621,642 ---- write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) { ! ssize_t have_written; ! ssize_t to_write_subrecord; int short_record; /* Stream I/O. */ if (is_stream_io (dtp)) { ! have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); ! if (unlikely (have_written < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } ! dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; return SUCCESS; } *************** write_buf (st_parameter_dt *dtp, void *b *** 667,680 **** if (buf == NULL && nbytes == 0) return SUCCESS; ! if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } ! dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes; ! dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes; return SUCCESS; } --- 654,668 ---- if (buf == NULL && nbytes == 0) return SUCCESS; ! have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); ! if (unlikely (have_written < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } ! dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; ! dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written; return SUCCESS; } *************** write_buf (st_parameter_dt *dtp, void *b *** 704,711 **** dtp->u.p.current_unit->bytes_left_subrecord -= (gfc_offset) to_write_subrecord; ! if (unlikely (swrite (dtp->u.p.current_unit->s, buf + have_written, ! &to_write_subrecord) != 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; --- 692,700 ---- dtp->u.p.current_unit->bytes_left_subrecord -= (gfc_offset) to_write_subrecord; ! to_write_subrecord = swrite (dtp->u.p.current_unit->s, ! buf + have_written, to_write_subrecord); ! if (unlikely (to_write_subrecord < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; *************** static void *** 737,756 **** unformatted_read (st_parameter_dt *dtp, bt type, void *dest, int kind, size_t size, size_t nelems) { - size_t i, sz; - if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) || kind == 1) { - sz = size * nelems; if (type == BT_CHARACTER) ! sz *= GFC_SIZE_OF_CHAR_KIND(kind); ! read_block_direct (dtp, dest, &sz); } else { char buffer[16]; char *p; p = dest; --- 726,743 ---- unformatted_read (st_parameter_dt *dtp, bt type, void *dest, int kind, size_t size, size_t nelems) { if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) || kind == 1) { if (type == BT_CHARACTER) ! size *= GFC_SIZE_OF_CHAR_KIND(kind); ! read_block_direct (dtp, dest, size * nelems); } else { char buffer[16]; char *p; + size_t i; p = dest; *************** unformatted_read (st_parameter_dt *dtp, *** 773,779 **** for (i = 0; i < nelems; i++) { ! read_block_direct (dtp, buffer, &size); reverse_memcpy (p, buffer, size); p += size; } --- 760,766 ---- for (i = 0; i < nelems; i++) { ! read_block_direct (dtp, buffer, size); reverse_memcpy (p, buffer, size); p += size; } *************** require_type (st_parameter_dt *dtp, bt e *** 915,933 **** } ! /* This subroutine is the main loop for a formatted data transfer statement. It would be natural to implement this as a coroutine with the user program, but C makes that awkward. We loop, processing format elements. When we actually have to transfer data instead of just setting flags, we return control to the user ! program which calls a subroutine that supplies the address and type of the next element, then comes back here to process it. */ static void ! formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, ! size_t size) { - char scratch[SCRATCH_SIZE]; int pos, bytes_used; const fnode *f; format_token t; --- 902,919 ---- } ! /* This function is in the main loop for a formatted data transfer statement. It would be natural to implement this as a coroutine with the user program, but C makes that awkward. We loop, processing format elements. When we actually have to transfer data instead of just setting flags, we return control to the user ! program which calls a function that supplies the address and type of the next element, then comes back here to process it. */ static void ! formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind, ! size_t size) { int pos, bytes_used; const fnode *f; format_token t; *************** formatted_transfer_scalar (st_parameter_ *** 954,960 **** dtp->u.p.sf_read_comma = dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; ! dtp->u.p.line_buffer = scratch; for (;;) { --- 940,1286 ---- dtp->u.p.sf_read_comma = dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; ! for (;;) ! { ! /* If reversion has occurred and there is another real data item, ! then we have to move to the next record. */ ! if (dtp->u.p.reversion_flag && n > 0) ! { ! dtp->u.p.reversion_flag = 0; ! next_record (dtp, 0); ! } ! ! consume_data_flag = 1; ! if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) ! break; ! ! f = next_format (dtp); ! if (f == NULL) ! { ! /* No data descriptors left. */ ! if (unlikely (n > 0)) ! generate_error (&dtp->common, LIBERROR_FORMAT, ! "Insufficient data descriptors in format after reversion"); ! return; ! } ! ! t = f->format; ! ! bytes_used = (int)(dtp->u.p.current_unit->recl ! - dtp->u.p.current_unit->bytes_left); ! ! if (is_stream_io(dtp)) ! bytes_used = 0; ! ! switch (t) ! { ! case FMT_I: ! if (n == 0) ! goto need_read_data; ! if (require_type (dtp, BT_INTEGER, type, f)) ! return; ! read_decimal (dtp, f, p, kind); ! break; ! ! case FMT_B: ! if (n == 0) ! goto need_read_data; ! if (compile_options.allow_std < GFC_STD_GNU ! && require_type (dtp, BT_INTEGER, type, f)) ! return; ! read_radix (dtp, f, p, kind, 2); ! break; ! ! case FMT_O: ! if (n == 0) ! goto need_read_data; ! if (compile_options.allow_std < GFC_STD_GNU ! && require_type (dtp, BT_INTEGER, type, f)) ! return; ! read_radix (dtp, f, p, kind, 8); ! break; ! ! case FMT_Z: ! if (n == 0) ! goto need_read_data; ! if (compile_options.allow_std < GFC_STD_GNU ! && require_type (dtp, BT_INTEGER, type, f)) ! return; ! read_radix (dtp, f, p, kind, 16); ! break; ! ! case FMT_A: ! if (n == 0) ! goto need_read_data; ! ! /* It is possible to have FMT_A with something not BT_CHARACTER such ! as when writing out hollerith strings, so check both type ! and kind before calling wide character routines. */ ! if (type == BT_CHARACTER && kind == 4) ! read_a_char4 (dtp, f, p, size); ! else ! read_a (dtp, f, p, size); ! break; ! ! case FMT_L: ! if (n == 0) ! goto need_read_data; ! read_l (dtp, f, p, kind); ! break; ! ! case FMT_D: ! if (n == 0) ! goto need_read_data; ! if (require_type (dtp, BT_REAL, type, f)) ! return; ! read_f (dtp, f, p, kind); ! break; ! ! case FMT_E: ! if (n == 0) ! goto need_read_data; ! if (require_type (dtp, BT_REAL, type, f)) ! return; ! read_f (dtp, f, p, kind); ! break; ! ! case FMT_EN: ! if (n == 0) ! goto need_read_data; ! if (require_type (dtp, BT_REAL, type, f)) ! return; ! read_f (dtp, f, p, kind); ! break; ! ! case FMT_ES: ! if (n == 0) ! goto need_read_data; ! if (require_type (dtp, BT_REAL, type, f)) ! return; ! read_f (dtp, f, p, kind); ! break; ! ! case FMT_F: ! if (n == 0) ! goto need_read_data; ! if (require_type (dtp, BT_REAL, type, f)) ! return; ! read_f (dtp, f, p, kind); ! break; ! ! case FMT_G: ! if (n == 0) ! goto need_read_data; ! switch (type) ! { ! case BT_INTEGER: ! read_decimal (dtp, f, p, kind); ! break; ! case BT_LOGICAL: ! read_l (dtp, f, p, kind); ! break; ! case BT_CHARACTER: ! if (kind == 4) ! read_a_char4 (dtp, f, p, size); ! else ! read_a (dtp, f, p, size); ! break; ! case BT_REAL: ! read_f (dtp, f, p, kind); ! break; ! default: ! internal_error (&dtp->common, "formatted_transfer(): Bad type"); ! } ! break; ! ! case FMT_STRING: ! consume_data_flag = 0; ! format_error (dtp, f, "Constant string in input format"); ! return; ! ! /* Format codes that don't transfer data. */ ! case FMT_X: ! case FMT_TR: ! consume_data_flag = 0; ! dtp->u.p.skips += f->u.n; ! pos = bytes_used + dtp->u.p.skips - 1; ! dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1; ! read_x (dtp, f->u.n); ! break; ! ! case FMT_TL: ! case FMT_T: ! consume_data_flag = 0; ! ! if (f->format == FMT_TL) ! { ! /* Handle the special case when no bytes have been used yet. ! Cannot go below zero. */ ! if (bytes_used == 0) ! { ! dtp->u.p.pending_spaces -= f->u.n; ! dtp->u.p.skips -= f->u.n; ! dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips; ! } ! ! pos = bytes_used - f->u.n; ! } ! else /* FMT_T */ ! 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; ! ! dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used; ! dtp->u.p.pending_spaces = dtp->u.p.pending_spaces ! + pos - dtp->u.p.max_pos; ! dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ! ? 0 : dtp->u.p.pending_spaces; ! if (dtp->u.p.skips == 0) ! break; ! ! /* Adjust everything for end-of-record condition */ ! if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp)) ! { ! dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor; ! dtp->u.p.skips -= dtp->u.p.sf_seen_eor; ! bytes_used = pos; ! dtp->u.p.sf_seen_eor = 0; ! } ! if (dtp->u.p.skips < 0) ! { ! if (is_internal_unit (dtp)) ! sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR); ! else ! fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR); ! dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; ! dtp->u.p.skips = dtp->u.p.pending_spaces = 0; ! } ! else ! read_x (dtp, dtp->u.p.skips); ! break; ! ! case FMT_S: ! consume_data_flag = 0; ! dtp->u.p.sign_status = SIGN_S; ! break; ! ! case FMT_SS: ! consume_data_flag = 0; ! dtp->u.p.sign_status = SIGN_SS; ! break; ! ! case FMT_SP: ! consume_data_flag = 0; ! dtp->u.p.sign_status = SIGN_SP; ! break; ! ! case FMT_BN: ! consume_data_flag = 0 ; ! dtp->u.p.blank_status = BLANK_NULL; ! break; ! ! case FMT_BZ: ! consume_data_flag = 0; ! dtp->u.p.blank_status = BLANK_ZERO; ! break; ! ! case FMT_DC: ! consume_data_flag = 0; ! dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA; ! break; ! ! case FMT_DP: ! consume_data_flag = 0; ! dtp->u.p.current_unit->decimal_status = DECIMAL_POINT; ! break; ! ! case FMT_P: ! consume_data_flag = 0; ! dtp->u.p.scale_factor = f->u.k; ! break; ! ! case FMT_DOLLAR: ! consume_data_flag = 0; ! dtp->u.p.seen_dollar = 1; ! break; ! ! case FMT_SLASH: ! consume_data_flag = 0; ! dtp->u.p.skips = dtp->u.p.pending_spaces = 0; ! next_record (dtp, 0); ! break; ! ! case FMT_COLON: ! /* A colon descriptor causes us to exit this loop (in ! 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; ! ! default: ! internal_error (&dtp->common, "Bad format node"); ! } ! ! /* Adjust the item count and data pointer. */ ! ! if ((consume_data_flag > 0) && (n > 0)) ! { ! n--; ! p = ((char *) p) + size; ! } ! ! dtp->u.p.skips = 0; ! ! pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); ! dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; ! } ! ! return; ! ! /* Come here when we need a data descriptor but don't have one. We ! push the current format node back onto the input, then return and ! let the user program call us back with the data. */ ! need_read_data: ! unget_format (dtp, f); ! } ! ! ! static void ! formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind, ! size_t size) ! { ! int pos, bytes_used; ! const fnode *f; ! format_token t; ! int n; ! int consume_data_flag; ! ! /* Change a complex data item into a pair of reals. */ ! ! n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2); ! if (type == BT_COMPLEX) ! { ! type = BT_REAL; ! size /= 2; ! } ! ! /* If there's an EOR condition, we simulate finalizing the transfer ! by doing nothing. */ ! if (dtp->u.p.eor_condition) ! return; ! ! /* Set this flag so that commas in reads cause the read to complete before ! the entire field has been read. The next read field will start right after ! the comma in the stream. (Set to 0 for character reads). */ ! dtp->u.p.sf_read_comma = ! dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; for (;;) { *************** formatted_transfer_scalar (st_parameter_ *** 1003,1011 **** if (dtp->u.p.skips < 0) { if (is_internal_unit (dtp)) ! move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips); else ! fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips); dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; } dtp->u.p.skips = dtp->u.p.pending_spaces = 0; --- 1329,1337 ---- if (dtp->u.p.skips < 0) { if (is_internal_unit (dtp)) ! sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR); else ! fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR); dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; } dtp->u.p.skips = dtp->u.p.pending_spaces = 0; *************** formatted_transfer_scalar (st_parameter_ *** 1024,1080 **** goto need_data; if (require_type (dtp, BT_INTEGER, type, f)) return; ! ! if (dtp->u.p.mode == READING) ! read_decimal (dtp, f, p, kind); ! else ! write_i (dtp, f, p, kind); ! break; case FMT_B: if (n == 0) goto need_data; - if (compile_options.allow_std < GFC_STD_GNU && require_type (dtp, BT_INTEGER, type, f)) return; ! ! if (dtp->u.p.mode == READING) ! read_radix (dtp, f, p, kind, 2); ! else ! write_b (dtp, f, p, kind); ! break; case FMT_O: if (n == 0) goto need_data; - if (compile_options.allow_std < GFC_STD_GNU && require_type (dtp, BT_INTEGER, type, f)) return; ! ! if (dtp->u.p.mode == READING) ! read_radix (dtp, f, p, kind, 8); ! else ! write_o (dtp, f, p, kind); ! break; case FMT_Z: if (n == 0) goto need_data; - if (compile_options.allow_std < GFC_STD_GNU && require_type (dtp, BT_INTEGER, type, f)) return; ! ! if (dtp->u.p.mode == READING) ! read_radix (dtp, f, p, kind, 16); ! else ! write_z (dtp, f, p, kind); ! break; case FMT_A: --- 1350,1383 ---- goto need_data; if (require_type (dtp, BT_INTEGER, type, f)) return; ! write_i (dtp, f, p, kind); break; case FMT_B: if (n == 0) goto need_data; if (compile_options.allow_std < GFC_STD_GNU && require_type (dtp, BT_INTEGER, type, f)) return; ! write_b (dtp, f, p, kind); break; case FMT_O: if (n == 0) goto need_data; if (compile_options.allow_std < GFC_STD_GNU && require_type (dtp, BT_INTEGER, type, f)) return; ! write_o (dtp, f, p, kind); break; case FMT_Z: if (n == 0) goto need_data; if (compile_options.allow_std < GFC_STD_GNU && require_type (dtp, BT_INTEGER, type, f)) return; ! write_z (dtp, f, p, kind); break; case FMT_A: *************** formatted_transfer_scalar (st_parameter_ *** 1084,1114 **** /* It is possible to have FMT_A with something not BT_CHARACTER such as when writing out hollerith strings, so check both type and kind before calling wide character routines. */ ! if (dtp->u.p.mode == READING) ! { ! if (type == BT_CHARACTER && kind == 4) ! read_a_char4 (dtp, f, p, size); ! else ! read_a (dtp, f, p, size); ! } else ! { ! if (type == BT_CHARACTER && kind == 4) ! write_a_char4 (dtp, f, p, size); ! else ! write_a (dtp, f, p, size); ! } break; case FMT_L: if (n == 0) goto need_data; ! ! if (dtp->u.p.mode == READING) ! read_l (dtp, f, p, kind); ! else ! write_l (dtp, f, p, kind); ! break; case FMT_D: --- 1387,1402 ---- /* It is possible to have FMT_A with something not BT_CHARACTER such as when writing out hollerith strings, so check both type and kind before calling wide character routines. */ ! if (type == BT_CHARACTER && kind == 4) ! write_a_char4 (dtp, f, p, size); else ! write_a (dtp, f, p, size); break; case FMT_L: if (n == 0) goto need_data; ! write_l (dtp, f, p, kind); break; case FMT_D: *************** formatted_transfer_scalar (st_parameter_ *** 1116,1127 **** goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! ! if (dtp->u.p.mode == READING) ! read_f (dtp, f, p, kind); ! else ! write_d (dtp, f, p, kind); ! break; case FMT_E: --- 1404,1410 ---- goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! write_d (dtp, f, p, kind); break; case FMT_E: *************** formatted_transfer_scalar (st_parameter_ *** 1129,1139 **** goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! ! if (dtp->u.p.mode == READING) ! read_f (dtp, f, p, kind); ! else ! write_e (dtp, f, p, kind); break; case FMT_EN: --- 1412,1418 ---- goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! write_e (dtp, f, p, kind); break; case FMT_EN: *************** formatted_transfer_scalar (st_parameter_ *** 1141,1152 **** goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! ! if (dtp->u.p.mode == READING) ! read_f (dtp, f, p, kind); ! else ! write_en (dtp, f, p, kind); ! break; case FMT_ES: --- 1420,1426 ---- goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! write_en (dtp, f, p, kind); break; case FMT_ES: *************** formatted_transfer_scalar (st_parameter_ *** 1154,1165 **** goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! ! if (dtp->u.p.mode == READING) ! read_f (dtp, f, p, kind); ! else ! write_es (dtp, f, p, kind); ! break; case FMT_F: --- 1428,1434 ---- goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! write_es (dtp, f, p, kind); break; case FMT_F: *************** formatted_transfer_scalar (st_parameter_ *** 1167,1207 **** goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! ! if (dtp->u.p.mode == READING) ! read_f (dtp, f, p, kind); ! else ! write_f (dtp, f, p, kind); ! break; case FMT_G: if (n == 0) goto need_data; ! if (dtp->u.p.mode == READING) ! switch (type) ! { ! case BT_INTEGER: ! read_decimal (dtp, f, p, kind); ! break; ! case BT_LOGICAL: ! read_l (dtp, f, p, kind); ! break; ! case BT_CHARACTER: ! if (kind == 4) ! read_a_char4 (dtp, f, p, size); ! else ! read_a (dtp, f, p, size); ! break; ! case BT_REAL: ! read_f (dtp, f, p, kind); ! break; ! default: ! goto bad_type; ! } ! else ! switch (type) ! { case BT_INTEGER: write_i (dtp, f, p, kind); break; --- 1436,1449 ---- goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; ! write_f (dtp, f, p, kind); break; case FMT_G: if (n == 0) goto need_data; ! switch (type) ! { case BT_INTEGER: write_i (dtp, f, p, kind); break; *************** formatted_transfer_scalar (st_parameter_ *** 1216,1240 **** break; case BT_REAL: if (f->u.real.w == 0) ! write_real_g0 (dtp, p, kind, f->u.real.d); else write_d (dtp, f, p, kind); break; default: - bad_type: internal_error (&dtp->common, "formatted_transfer(): Bad type"); ! } ! break; case FMT_STRING: consume_data_flag = 0; - if (dtp->u.p.mode == READING) - { - format_error (dtp, f, "Constant string in input format"); - return; - } write_constant_string (dtp, f); break; --- 1458,1475 ---- break; case BT_REAL: if (f->u.real.w == 0) ! write_real_g0 (dtp, p, kind, f->u.real.d); else write_d (dtp, f, p, kind); break; default: internal_error (&dtp->common, "formatted_transfer(): Bad type"); ! } break; case FMT_STRING: consume_data_flag = 0; write_constant_string (dtp, f); break; *************** formatted_transfer_scalar (st_parameter_ *** 1246,1266 **** dtp->u.p.skips += f->u.n; pos = bytes_used + dtp->u.p.skips - 1; dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1; - /* Writes occur just before the switch on f->format, above, so that trailing blanks are suppressed, unless we are doing a non-advancing write in which case we want to output the blanks now. */ ! if (dtp->u.p.mode == WRITING ! && dtp->u.p.advance_status == ADVANCE_NO) { write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); dtp->u.p.skips = dtp->u.p.pending_spaces = 0; } - - if (dtp->u.p.mode == READING) - read_x (dtp, f->u.n); - break; case FMT_TL: --- 1481,1495 ---- dtp->u.p.skips += f->u.n; pos = bytes_used + dtp->u.p.skips - 1; dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1; /* Writes occur just before the switch on f->format, above, so that trailing blanks are suppressed, unless we are doing a non-advancing write in which case we want to output the blanks now. */ ! if (dtp->u.p.advance_status == ADVANCE_NO) { write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); dtp->u.p.skips = dtp->u.p.pending_spaces = 0; } break; case FMT_TL: *************** formatted_transfer_scalar (st_parameter_ *** 1282,1293 **** pos = bytes_used - f->u.n; } else /* FMT_T */ ! { ! if (dtp->u.p.mode == READING) ! pos = f->u.n - 1; ! else ! pos = f->u.n - dtp->u.p.pending_spaces - 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 --- 1511,1517 ---- pos = bytes_used - f->u.n; } else /* FMT_T */ ! pos = f->u.n - dtp->u.p.pending_spaces - 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 *************** formatted_transfer_scalar (st_parameter_ *** 1300,1342 **** + pos - dtp->u.p.max_pos; dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0 : dtp->u.p.pending_spaces; - - if (dtp->u.p.skips == 0) - break; - - /* Writes occur just before the switch on f->format, above, so that - trailing blanks are suppressed. */ - if (dtp->u.p.mode == READING) - { - /* Adjust everything for end-of-record condition */ - if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp)) - { - if (dtp->u.p.sf_seen_eor == 2) - { - /* The EOR was a CRLF (two bytes wide). */ - dtp->u.p.current_unit->bytes_left -= 2; - dtp->u.p.skips -= 2; - } - else - { - /* The EOR marker was only one byte wide. */ - dtp->u.p.current_unit->bytes_left--; - dtp->u.p.skips--; - } - bytes_used = pos; - dtp->u.p.sf_seen_eor = 0; - } - if (dtp->u.p.skips < 0) - { - move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips); - dtp->u.p.current_unit->bytes_left - -= (gfc_offset) dtp->u.p.skips; - dtp->u.p.skips = dtp->u.p.pending_spaces = 0; - } - else - read_x (dtp, dtp->u.p.skips); - } - break; case FMT_S: --- 1524,1529 ---- *************** formatted_transfer_scalar (st_parameter_ *** 1404,1433 **** internal_error (&dtp->common, "Bad format node"); } - /* Free a buffer that we had to allocate during a sequential - formatted read of a block that was larger than the static - buffer. */ - - if (dtp->u.p.line_buffer != scratch) - { - free_mem (dtp->u.p.line_buffer); - dtp->u.p.line_buffer = scratch; - } - /* Adjust the item count and data pointer. */ if ((consume_data_flag > 0) && (n > 0)) ! { ! n--; ! p = ((char *) p) + size; ! } ! ! if (dtp->u.p.mode == READING) ! dtp->u.p.skips = 0; pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; - } return; --- 1591,1606 ---- internal_error (&dtp->common, "Bad format node"); } /* Adjust the item count and data pointer. */ if ((consume_data_flag > 0) && (n > 0)) ! { ! n--; ! p = ((char *) p) + size; ! } pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; } return; *************** formatted_transfer_scalar (st_parameter_ *** 1439,1444 **** --- 1612,1618 ---- unget_format (dtp, f); } + static void formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind, size_t size, size_t nelems) *************** formatted_transfer (st_parameter_dt *dtp *** 1449,1464 **** tmp = (char *) p; size_t stride = type == BT_CHARACTER ? size * GFC_SIZE_OF_CHAR_KIND(kind) : size; ! /* Big loop over all the elements. */ ! for (elem = 0; elem < nelems; elem++) { ! dtp->u.p.item_count++; ! formatted_transfer_scalar (dtp, type, tmp + stride*elem, kind, size); } } - /* Data transfer entry points. The type of the data entity is implicit in the subroutine call. This prevents us from having to share a common enum with the compiler. */ --- 1623,1649 ---- tmp = (char *) p; size_t stride = type == BT_CHARACTER ? size * GFC_SIZE_OF_CHAR_KIND(kind) : size; ! if (dtp->u.p.mode == READING) { ! /* Big loop over all the elements. */ ! for (elem = 0; elem < nelems; elem++) ! { ! dtp->u.p.item_count++; ! formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size); ! } ! } ! else ! { ! /* Big loop over all the elements. */ ! for (elem = 0; elem < nelems; elem++) ! { ! dtp->u.p.item_count++; ! formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size); ! } } } /* Data transfer entry points. The type of the data entity is implicit in the subroutine call. This prevents us from having to share a common enum with the compiler. */ *************** transfer_array (st_parameter_dt *dtp, gf *** 1652,1685 **** static void us_read (st_parameter_dt *dtp, int continued) { ! size_t n, nr; GFC_INTEGER_4 i4; GFC_INTEGER_8 i8; gfc_offset i; - if (dtp->u.p.current_unit->endfile == AT_ENDFILE) - return; - if (compile_options.record_marker == 0) n = sizeof (GFC_INTEGER_4); else n = compile_options.record_marker; ! nr = n; ! ! if (unlikely (sread (dtp->u.p.current_unit->s, &i, &n) != 0)) { generate_error (&dtp->common, LIBERROR_BAD_US, NULL); return; } ! ! if (n == 0) { ! dtp->u.p.current_unit->endfile = AT_ENDFILE; return; /* end of file */ } ! ! if (unlikely (n != nr)) { generate_error (&dtp->common, LIBERROR_BAD_US, NULL); return; --- 1837,1864 ---- static void us_read (st_parameter_dt *dtp, int continued) { ! ssize_t n, nr; GFC_INTEGER_4 i4; GFC_INTEGER_8 i8; gfc_offset i; if (compile_options.record_marker == 0) n = sizeof (GFC_INTEGER_4); else n = compile_options.record_marker; ! nr = sread (dtp->u.p.current_unit->s, &i, n); ! if (unlikely (nr < 0)) { generate_error (&dtp->common, LIBERROR_BAD_US, NULL); return; } ! else if (nr == 0) { ! hit_eof (dtp); return; /* end of file */ } ! else if (unlikely (n != nr)) { generate_error (&dtp->common, LIBERROR_BAD_US, NULL); return; *************** us_read (st_parameter_dt *dtp, int conti *** 1745,1751 **** static void us_write (st_parameter_dt *dtp, int continued) { ! size_t nbytes; gfc_offset dummy; dummy = 0; --- 1924,1930 ---- static void us_write (st_parameter_dt *dtp, int continued) { ! ssize_t nbytes; gfc_offset dummy; dummy = 0; *************** us_write (st_parameter_dt *dtp, int cont *** 1755,1761 **** else nbytes = compile_options.record_marker ; ! if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0) generate_error (&dtp->common, LIBERROR_OS, NULL); /* For sequential unformatted, if RECL= was not specified in the OPEN --- 1934,1940 ---- else nbytes = compile_options.record_marker ; ! if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes) generate_error (&dtp->common, LIBERROR_OS, NULL); /* For sequential unformatted, if RECL= was not specified in the OPEN *************** data_transfer_init (st_parameter_dt *dtp *** 1957,1963 **** return; } ! /* Check the record number. */ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT && (cf & IOPARM_DT_HAS_REC) == 0) --- 2136,2142 ---- return; } ! /* Check the record or position number. */ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT && (cf & IOPARM_DT_HAS_REC) == 0) *************** data_transfer_init (st_parameter_dt *dtp *** 2106,2170 **** if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED) dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad; ! /* Check the POS= specifier: that it is in range and that it is used with a unit that has been connected for STREAM access. F2003 9.5.1.10. */ if (((cf & IOPARM_DT_HAS_POS) != 0)) { if (is_stream_io (dtp)) ! { ! ! if (dtp->pos <= 0) ! { ! generate_error (&dtp->common, LIBERROR_BAD_OPTION, ! "POS=specifier must be positive"); ! return; ! } ! ! if (dtp->pos >= dtp->u.p.current_unit->maxrec) ! { ! generate_error (&dtp->common, LIBERROR_BAD_OPTION, ! "POS=specifier too large"); ! return; ! } ! ! dtp->rec = dtp->pos; ! ! if (dtp->u.p.mode == READING) ! { ! /* Required for compatibility between 4.3 and 4.4 runtime. Check ! to see if we might be reading what we wrote before */ ! if (dtp->u.p.current_unit->mode == WRITING) ! { ! fbuf_flush (dtp->u.p.current_unit, 1); ! flush(dtp->u.p.current_unit->s); ! } ! ! if (dtp->pos < file_length (dtp->u.p.current_unit->s)) ! dtp->u.p.current_unit->endfile = NO_ENDFILE; ! } ! ! if (dtp->pos != dtp->u.p.current_unit->strm_pos) ! { ! fbuf_flush (dtp->u.p.current_unit, 1); ! flush (dtp->u.p.current_unit->s); ! if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1) == FAILURE) ! { ! generate_error (&dtp->common, LIBERROR_OS, NULL); ! return; ! } ! dtp->u.p.current_unit->strm_pos = dtp->pos; ! } ! } else ! { ! generate_error (&dtp->common, LIBERROR_BAD_OPTION, ! "POS=specifier not allowed, " ! "Try OPEN with ACCESS='stream'"); ! return; ! } } /* Sanity checks on the record number. */ if ((cf & IOPARM_DT_HAS_REC) != 0) --- 2285,2354 ---- if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED) dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad; ! ! /* Check to see if we might be reading what we wrote before */ ! ! if (dtp->u.p.mode != dtp->u.p.current_unit->mode ! && !is_internal_unit (dtp)) ! { ! int pos = fbuf_reset (dtp->u.p.current_unit); ! if (pos != 0) ! sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR); ! sflush(dtp->u.p.current_unit->s); ! } ! /* Check the POS= specifier: that it is in range and that it is used with a unit that has been connected for STREAM access. F2003 9.5.1.10. */ if (((cf & IOPARM_DT_HAS_POS) != 0)) { if (is_stream_io (dtp)) ! { ! ! if (dtp->pos <= 0) ! { ! generate_error (&dtp->common, LIBERROR_BAD_OPTION, ! "POS=specifier must be positive"); ! return; ! } ! ! if (dtp->pos >= dtp->u.p.current_unit->maxrec) ! { ! generate_error (&dtp->common, LIBERROR_BAD_OPTION, ! "POS=specifier too large"); ! return; ! } ! ! dtp->rec = dtp->pos; ! ! if (dtp->u.p.mode == READING) ! { ! /* Reset the endfile flag; if we hit EOF during reading ! we'll set the flag and generate an error at that point ! rather than worrying about it here. */ ! dtp->u.p.current_unit->endfile = NO_ENDFILE; ! } ! ! if (dtp->pos != dtp->u.p.current_unit->strm_pos) ! { ! fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); ! if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0) ! { ! generate_error (&dtp->common, LIBERROR_OS, NULL); ! return; ! } ! dtp->u.p.current_unit->strm_pos = dtp->pos; ! } ! } else ! { ! generate_error (&dtp->common, LIBERROR_BAD_OPTION, ! "POS=specifier not allowed, " ! "Try OPEN with ACCESS='stream'"); ! return; ! } } + /* Sanity checks on the record number. */ if ((cf & IOPARM_DT_HAS_REC) != 0) *************** data_transfer_init (st_parameter_dt *dtp *** 2183,2197 **** return; } ! /* Check to see if we might be reading what we wrote before */ - if (dtp->u.p.mode == READING - && dtp->u.p.current_unit->mode == WRITING - && !is_internal_unit (dtp)) - { - fbuf_flush (dtp->u.p.current_unit, 1); - flush(dtp->u.p.current_unit->s); - } /* Check whether the record exists to be read. Only a partial record needs to exist. */ --- 2367,2376 ---- return; } ! /* Make sure format buffer is reset. */ ! if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED) ! fbuf_reset (dtp->u.p.current_unit); /* Check whether the record exists to be read. Only a partial record needs to exist. */ *************** data_transfer_init (st_parameter_dt *dtp *** 2206,2242 **** /* Position the file. */ if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1) ! * dtp->u.p.current_unit->recl) == FAILURE) ! { ! generate_error (&dtp->common, LIBERROR_OS, NULL); ! return; ! } /* TODO: This is required to maintain compatibility between ! 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */ if (is_stream_io (dtp)) ! dtp->u.p.current_unit->strm_pos = dtp->rec; ! /* TODO: Un-comment this code when ABI changes from 4.3. if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM) ! { ! generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, ! "Record number not allowed for stream access " ! "data transfer"); ! return; ! } */ ! } - /* Overwriting an existing sequential file ? - it is always safe to truncate the file on the first write */ - if (dtp->u.p.mode == WRITING - && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL - && dtp->u.p.current_unit->last_record == 0 - && !is_preconnected(dtp->u.p.current_unit->s)) - struncate(dtp->u.p.current_unit->s); - /* Bugware for badly written mixed C-Fortran I/O. */ flush_if_preconnected(dtp->u.p.current_unit->s); --- 2385,2412 ---- /* Position the file. */ if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1) ! * dtp->u.p.current_unit->recl, SEEK_SET) < 0) ! { ! generate_error (&dtp->common, LIBERROR_OS, NULL); ! return; ! } /* TODO: This is required to maintain compatibility between ! 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */ if (is_stream_io (dtp)) ! dtp->u.p.current_unit->strm_pos = dtp->rec; ! /* TODO: Un-comment this code when ABI changes from 4.3. if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM) ! { ! generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, ! "Record number not allowed for stream access " ! "data transfer"); ! return; ! } */ } /* Bugware for badly written mixed C-Fortran I/O. */ flush_if_preconnected(dtp->u.p.current_unit->s); *************** next_array_record (st_parameter_dt *dtp, *** 2387,2397 **** position. */ static void ! skip_record (st_parameter_dt *dtp, size_t bytes) { ! gfc_offset new; ! size_t rlength; ! static const size_t MAX_READ = 4096; char p[MAX_READ]; dtp->u.p.current_unit->bytes_left_subrecord += bytes; --- 2557,2566 ---- position. */ static void ! skip_record (st_parameter_dt *dtp, ssize_t bytes) { ! ssize_t rlength, readb; ! static const ssize_t MAX_READ = 4096; char p[MAX_READ]; dtp->u.p.current_unit->bytes_left_subrecord += bytes; *************** skip_record (st_parameter_dt *dtp, size_ *** 2400,2411 **** if (is_seekable (dtp->u.p.current_unit->s)) { - new = file_position (dtp->u.p.current_unit->s) - + dtp->u.p.current_unit->bytes_left_subrecord; - /* Direct access files do not generate END conditions, only I/O errors. */ ! if (sseek (dtp->u.p.current_unit->s, new) == FAILURE) generate_error (&dtp->common, LIBERROR_OS, NULL); } else --- 2569,2578 ---- if (is_seekable (dtp->u.p.current_unit->s)) { /* Direct access files do not generate END conditions, only I/O errors. */ ! if (sseek (dtp->u.p.current_unit->s, ! dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0) generate_error (&dtp->common, LIBERROR_OS, NULL); } else *************** skip_record (st_parameter_dt *dtp, size_ *** 2413,2428 **** while (dtp->u.p.current_unit->bytes_left_subrecord > 0) { rlength = ! (MAX_READ > (size_t) dtp->u.p.current_unit->bytes_left_subrecord) ? ! MAX_READ : (size_t) dtp->u.p.current_unit->bytes_left_subrecord; ! if (sread (dtp->u.p.current_unit->s, p, &rlength) != 0) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } ! dtp->u.p.current_unit->bytes_left_subrecord -= rlength; } } --- 2580,2596 ---- while (dtp->u.p.current_unit->bytes_left_subrecord > 0) { rlength = ! (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ? ! MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord; ! readb = sread (dtp->u.p.current_unit->s, p, rlength); ! if (readb < 0) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } ! dtp->u.p.current_unit->bytes_left_subrecord -= readb; } } *************** next_record_r (st_parameter_dt *dtp) *** 2470,2477 **** { gfc_offset record; int bytes_left; - size_t length; char p; switch (current_mode (dtp)) { --- 2638,2645 ---- { gfc_offset record; int bytes_left; char p; + int cc; switch (current_mode (dtp)) { *************** next_record_r (st_parameter_dt *dtp) *** 2491,2501 **** case FORMATTED_STREAM: case FORMATTED_SEQUENTIAL: ! length = 1; ! /* sf_read has already terminated input because of an '\n' */ ! if (dtp->u.p.sf_seen_eor) { dtp->u.p.sf_seen_eor = 0; break; } --- 2659,2670 ---- case FORMATTED_STREAM: case FORMATTED_SEQUENTIAL: ! /* read_sf has already terminated input because of an '\n', or ! we have hit EOF. */ ! if (dtp->u.p.sf_seen_eor || dtp->u.p.at_eof) { dtp->u.p.sf_seen_eor = 0; + dtp->u.p.at_eof = 0; break; } *************** next_record_r (st_parameter_dt *dtp) *** 2510,2516 **** /* Now seek to this record. */ record = record * dtp->u.p.current_unit->recl; ! if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); break; --- 2679,2685 ---- /* Now seek to this record. */ record = record * dtp->u.p.current_unit->recl; ! if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); break; *************** next_record_r (st_parameter_dt *dtp) *** 2522,2531 **** bytes_left = (int) dtp->u.p.current_unit->bytes_left; bytes_left = min_off (bytes_left, file_length (dtp->u.p.current_unit->s) ! - file_position (dtp->u.p.current_unit->s)); if (sseek (dtp->u.p.current_unit->s, ! file_position (dtp->u.p.current_unit->s) ! + bytes_left) == FAILURE) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); break; --- 2691,2699 ---- bytes_left = (int) dtp->u.p.current_unit->bytes_left; bytes_left = min_off (bytes_left, file_length (dtp->u.p.current_unit->s) ! - stell (dtp->u.p.current_unit->s)); if (sseek (dtp->u.p.current_unit->s, ! bytes_left, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); break; *************** next_record_r (st_parameter_dt *dtp) *** 2535,2576 **** } break; } ! else do { ! if (sread (dtp->u.p.current_unit->s, &p, &length) != 0) ! { ! generate_error (&dtp->common, LIBERROR_OS, NULL); ! break; ! } ! ! if (length == 0) { ! dtp->u.p.current_unit->endfile = AT_ENDFILE; ! break; } ! ! if (is_stream_io (dtp)) ! dtp->u.p.current_unit->strm_pos++; } - while (p != '\n'); - break; } - - if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL - && !dtp->u.p.namelist_mode - && dtp->u.p.current_unit->endfile == NO_ENDFILE - && (file_length (dtp->u.p.current_unit->s) == - file_position (dtp->u.p.current_unit->s))) - dtp->u.p.current_unit->endfile = AT_ENDFILE; - } /* Small utility function to write a record marker, taking care of byte swapping and of choosing the correct size. */ ! inline static int write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) { size_t len; --- 2703,2739 ---- } break; } ! else { ! do { ! errno = 0; ! cc = fbuf_getc (dtp->u.p.current_unit); ! if (cc == EOF) ! { ! if (errno != 0) ! generate_error (&dtp->common, LIBERROR_OS, NULL); ! else ! hit_eof (dtp); ! break; ! } ! ! if (is_stream_io (dtp)) ! dtp->u.p.current_unit->strm_pos++; ! ! p = (char) cc; } ! while (p != '\n'); } break; } } /* Small utility function to write a record marker, taking care of byte swapping and of choosing the correct size. */ ! static int write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) { size_t len; *************** write_us_marker (st_parameter_dt *dtp, c *** 2590,2601 **** { case sizeof (GFC_INTEGER_4): buf4 = buf; ! return swrite (dtp->u.p.current_unit->s, &buf4, &len); break; case sizeof (GFC_INTEGER_8): buf8 = buf; ! return swrite (dtp->u.p.current_unit->s, &buf8, &len); break; default: --- 2753,2764 ---- { case sizeof (GFC_INTEGER_4): buf4 = buf; ! return swrite (dtp->u.p.current_unit->s, &buf4, len); break; case sizeof (GFC_INTEGER_8): buf8 = buf; ! return swrite (dtp->u.p.current_unit->s, &buf8, len); break; default: *************** write_us_marker (st_parameter_dt *dtp, c *** 2610,2622 **** case sizeof (GFC_INTEGER_4): buf4 = buf; reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4)); ! return swrite (dtp->u.p.current_unit->s, p, &len); break; case sizeof (GFC_INTEGER_8): buf8 = buf; reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8)); ! return swrite (dtp->u.p.current_unit->s, p, &len); break; default: --- 2773,2785 ---- case sizeof (GFC_INTEGER_4): buf4 = buf; reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4)); ! return swrite (dtp->u.p.current_unit->s, p, len); break; case sizeof (GFC_INTEGER_8): buf8 = buf; reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8)); ! return swrite (dtp->u.p.current_unit->s, p, len); break; default: *************** write_us_marker (st_parameter_dt *dtp, c *** 2633,2645 **** static void next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) { ! gfc_offset c, m, m_write; ! size_t record_marker; /* Bytes written. */ m = dtp->u.p.current_unit->recl_subrecord - dtp->u.p.current_unit->bytes_left_subrecord; - c = file_position (dtp->u.p.current_unit->s); /* Write the length tail. If we finish a record containing subrecords, we write out the negative length. */ --- 2796,2806 ---- static void next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) { ! gfc_offset m, m_write, record_marker; /* Bytes written. */ m = dtp->u.p.current_unit->recl_subrecord - dtp->u.p.current_unit->bytes_left_subrecord; /* Write the length tail. If we finish a record containing subrecords, we write out the negative length. */ *************** next_record_w_unf (st_parameter_dt *dtp, *** 2649,2655 **** else m_write = m; ! if (unlikely (write_us_marker (dtp, m_write) != 0)) goto io_error; if (compile_options.record_marker == 0) --- 2810,2816 ---- else m_write = m; ! if (unlikely (write_us_marker (dtp, m_write) < 0)) goto io_error; if (compile_options.record_marker == 0) *************** next_record_w_unf (st_parameter_dt *dtp, *** 2660,2667 **** /* Seek to the head and overwrite the bogus length with the real length. */ ! if (unlikely (sseek (dtp->u.p.current_unit->s, c - m - record_marker) ! == FAILURE)) goto io_error; if (next_subrecord) --- 2821,2828 ---- /* Seek to the head and overwrite the bogus length with the real length. */ ! if (unlikely (sseek (dtp->u.p.current_unit->s, - m - 2 * record_marker, ! SEEK_CUR) < 0)) goto io_error; if (next_subrecord) *************** next_record_w_unf (st_parameter_dt *dtp, *** 2669,2681 **** else m_write = m; ! if (unlikely (write_us_marker (dtp, m_write) != 0)) goto io_error; /* Seek past the end of the current record. */ ! if (unlikely (sseek (dtp->u.p.current_unit->s, c + record_marker) ! == FAILURE)) goto io_error; return; --- 2830,2842 ---- else m_write = m; ! if (unlikely (write_us_marker (dtp, m_write) < 0)) goto io_error; /* Seek past the end of the current record. */ ! if (unlikely (sseek (dtp->u.p.current_unit->s, m + record_marker, ! SEEK_CUR) < 0)) goto io_error; return; *************** next_record_w_unf (st_parameter_dt *dtp, *** 2686,2691 **** --- 2847,2881 ---- } + + /* Utility function like memset() but operating on streams. Return + value is same as for POSIX write(). */ + + static ssize_t + sset (stream * s, int c, ssize_t nbyte) + { + static const int WRITE_CHUNK = 256; + char p[WRITE_CHUNK]; + ssize_t bytes_left, trans; + + if (nbyte < WRITE_CHUNK) + memset (p, c, nbyte); + else + memset (p, c, WRITE_CHUNK); + + bytes_left = nbyte; + while (bytes_left > 0) + { + trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK; + trans = swrite (s, p, trans); + if (trans <= 0) + return trans; + bytes_left -= trans; + } + + return nbyte - bytes_left; + } + /* Position to the next record in write mode. */ static void *************** next_record_w (st_parameter_dt *dtp, int *** 2694,2702 **** gfc_offset m, record, max_pos; int length; - /* Flush and reset the format buffer. */ - fbuf_flush (dtp->u.p.current_unit, 1); - /* Zero counters for X- and T-editing. */ max_pos = dtp->u.p.max_pos; dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0; --- 2884,2889 ---- *************** next_record_w (st_parameter_dt *dtp, int *** 2711,2718 **** if (dtp->u.p.current_unit->bytes_left == 0) break; if (sset (dtp->u.p.current_unit->s, ' ', ! dtp->u.p.current_unit->bytes_left) == FAILURE) goto io_error; break; --- 2898,2908 ---- if (dtp->u.p.current_unit->bytes_left == 0) break; + fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); + fbuf_flush (dtp->u.p.current_unit, WRITING); if (sset (dtp->u.p.current_unit->s, ' ', ! dtp->u.p.current_unit->bytes_left) ! != dtp->u.p.current_unit->bytes_left) goto io_error; break; *************** next_record_w (st_parameter_dt *dtp, int *** 2721,2727 **** if (dtp->u.p.current_unit->bytes_left > 0) { length = (int) dtp->u.p.current_unit->bytes_left; ! if (sset (dtp->u.p.current_unit->s, 0, length) == FAILURE) goto io_error; } break; --- 2911,2917 ---- if (dtp->u.p.current_unit->bytes_left > 0) { length = (int) dtp->u.p.current_unit->bytes_left; ! if (sset (dtp->u.p.current_unit->s, 0, length) != length) goto io_error; } break; *************** next_record_w (st_parameter_dt *dtp, int *** 2752,2759 **** { length = (int) (max_pos - m); if (sseek (dtp->u.p.current_unit->s, ! file_position (dtp->u.p.current_unit->s) ! + length) == FAILURE) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; --- 2942,2948 ---- { length = (int) (max_pos - m); if (sseek (dtp->u.p.current_unit->s, ! length, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; *************** next_record_w (st_parameter_dt *dtp, int *** 2761,2767 **** length = (int) (dtp->u.p.current_unit->recl - max_pos); } ! if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) { generate_error (&dtp->common, LIBERROR_END, NULL); return; --- 2950,2956 ---- length = (int) (dtp->u.p.current_unit->recl - max_pos); } ! if (sset (dtp->u.p.current_unit->s, ' ', length) != length) { generate_error (&dtp->common, LIBERROR_END, NULL); return; *************** next_record_w (st_parameter_dt *dtp, int *** 2777,2783 **** /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; ! if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; --- 2966,2972 ---- /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; ! if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; *************** next_record_w (st_parameter_dt *dtp, int *** 2800,2807 **** { length = (int) (max_pos - m); if (sseek (dtp->u.p.current_unit->s, ! file_position (dtp->u.p.current_unit->s) ! + length) == FAILURE) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; --- 2989,2995 ---- { length = (int) (max_pos - m); if (sseek (dtp->u.p.current_unit->s, ! length, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; *************** next_record_w (st_parameter_dt *dtp, int *** 2812,2818 **** length = (int) dtp->u.p.current_unit->bytes_left; } ! if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) { generate_error (&dtp->common, LIBERROR_END, NULL); return; --- 3000,3006 ---- length = (int) dtp->u.p.current_unit->bytes_left; } ! if (sset (dtp->u.p.current_unit->s, ' ', length) != length) { generate_error (&dtp->common, LIBERROR_END, NULL); return; *************** next_record_w (st_parameter_dt *dtp, int *** 2821,2843 **** } else { - size_t len; - const char crlf[] = "\r\n"; - #ifdef HAVE_CRLF ! len = 2; #else ! len = 1; #endif ! if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0) ! goto io_error; ! if (is_stream_io (dtp)) { dtp->u.p.current_unit->strm_pos += len; if (dtp->u.p.current_unit->strm_pos < file_length (dtp->u.p.current_unit->s)) ! struncate (dtp->u.p.current_unit->s); } } --- 3009,3035 ---- } else { #ifdef HAVE_CRLF ! const int len = 2; #else ! const int len = 1; #endif ! fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); ! char * p = fbuf_alloc (dtp->u.p.current_unit, len); ! if (!p) ! goto io_error; ! #ifdef HAVE_CRLF ! *(p++) = '\r'; ! #endif ! *p = '\n'; if (is_stream_io (dtp)) { dtp->u.p.current_unit->strm_pos += len; if (dtp->u.p.current_unit->strm_pos < file_length (dtp->u.p.current_unit->s)) ! unit_truncate (dtp->u.p.current_unit, ! dtp->u.p.current_unit->strm_pos - 1, ! &dtp->common); } } *************** next_record (st_parameter_dt *dtp, int d *** 2875,2881 **** dtp->u.p.current_unit->current_record = 0; if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { ! fp = file_position (dtp->u.p.current_unit->s); /* Calculate next record, rounding up partial records. */ dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1) / --- 3067,3073 ---- dtp->u.p.current_unit->current_record = 0; if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { ! fp = stell (dtp->u.p.current_unit->s); /* Calculate next record, rounding up partial records. */ dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1) / *************** next_record (st_parameter_dt *dtp, int d *** 2887,2892 **** --- 3079,3086 ---- if (!done) pre_position (dtp); + + fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); } *************** finalize_transfer (st_parameter_dt *dtp) *** 2910,2916 **** } if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) ! return; if ((dtp->u.p.ionml != NULL) && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0) --- 3104,3114 ---- } if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) ! { ! if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL) ! dtp->u.p.current_unit->current_record = 0; ! return; ! } if ((dtp->u.p.ionml != NULL) && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0) *************** finalize_transfer (st_parameter_dt *dtp) *** 2935,2941 **** if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING) { finish_list_read (dtp); - sfree (dtp->u.p.current_unit->s); return; } --- 3133,3138 ---- *************** finalize_transfer (st_parameter_dt *dtp) *** 2949,2960 **** && dtp->u.p.advance_status != ADVANCE_NO) next_record (dtp, 1); - if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED - && file_position (dtp->u.p.current_unit->s) >= dtp->rec) - { - flush (dtp->u.p.current_unit->s); - sfree (dtp->u.p.current_unit->s); - } return; } --- 3146,3151 ---- *************** finalize_transfer (st_parameter_dt *dtp) *** 2962,2970 **** if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar) { dtp->u.p.seen_dollar = 0; - fbuf_flush (dtp->u.p.current_unit, 1); - sfree (dtp->u.p.current_unit->s); return; } --- 3153,3160 ---- if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar) { + fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); dtp->u.p.seen_dollar = 0; return; } *************** finalize_transfer (st_parameter_dt *dtp) *** 2976,2990 **** - dtp->u.p.current_unit->bytes_left); dtp->u.p.current_unit->saved_pos = dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0; ! fbuf_flush (dtp->u.p.current_unit, 0); ! flush (dtp->u.p.current_unit->s); return; } dtp->u.p.current_unit->saved_pos = 0; next_record (dtp, 1); - sfree (dtp->u.p.current_unit->s); } /* Transfer function for IOLENGTH. It doesn't actually do any --- 3166,3181 ---- - dtp->u.p.current_unit->bytes_left); dtp->u.p.current_unit->saved_pos = dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0; ! fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); return; } + else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED + && dtp->u.p.mode == WRITING && !is_internal_unit (dtp)) + fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); dtp->u.p.current_unit->saved_pos = 0; next_record (dtp, 1); } /* Transfer function for IOLENGTH. It doesn't actually do any *************** iolength_transfer (st_parameter_dt *dtp, *** 2997,3003 **** size_t size, size_t nelems) { if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) ! *dtp->iolength += (GFC_IO_INT) size * nelems; } --- 3188,3194 ---- size_t size, size_t nelems) { if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) ! *dtp->iolength += (GFC_IO_INT) (size * nelems); } *************** void *** 3041,3048 **** st_iolength_done (st_parameter_dt *dtp __attribute__((unused))) { free_ionml (dtp); - if (dtp->u.p.scratch != NULL) - free_mem (dtp->u.p.scratch); library_end (); } --- 3232,3237 ---- *************** st_read (st_parameter_dt *dtp) *** 3058,3086 **** library_start (&dtp->common); data_transfer_init (dtp, 1); - - /* Handle complications dealing with the endfile record. */ - - if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) - switch (dtp->u.p.current_unit->endfile) - { - case NO_ENDFILE: - break; - - case AT_ENDFILE: - if (!is_internal_unit (dtp)) - { - generate_error (&dtp->common, LIBERROR_END, NULL); - dtp->u.p.current_unit->endfile = AFTER_ENDFILE; - dtp->u.p.current_unit->current_record = 0; - } - break; - - case AFTER_ENDFILE: - generate_error (&dtp->common, LIBERROR_ENDFILE, NULL); - dtp->u.p.current_unit->current_record = 0; - break; - } } extern void st_read_done (st_parameter_dt *); --- 3247,3252 ---- *************** st_read_done (st_parameter_dt *dtp) *** 3092,3099 **** finalize_transfer (dtp); free_format_data (dtp); free_ionml (dtp); - if (dtp->u.p.scratch != NULL) - free_mem (dtp->u.p.scratch); if (dtp->u.p.current_unit != NULL) unlock_unit (dtp->u.p.current_unit); --- 3258,3263 ---- *************** st_write_done (st_parameter_dt *dtp) *** 3136,3154 **** case NO_ENDFILE: /* Get rid of whatever is after this record. */ if (!is_internal_unit (dtp)) ! { ! flush (dtp->u.p.current_unit->s); ! if (struncate (dtp->u.p.current_unit->s) == FAILURE) ! generate_error (&dtp->common, LIBERROR_OS, NULL); ! } dtp->u.p.current_unit->endfile = AT_ENDFILE; break; } free_format_data (dtp); free_ionml (dtp); - if (dtp->u.p.scratch != NULL) - free_mem (dtp->u.p.scratch); if (dtp->u.p.current_unit != NULL) unlock_unit (dtp->u.p.current_unit); --- 3300,3314 ---- case NO_ENDFILE: /* Get rid of whatever is after this record. */ if (!is_internal_unit (dtp)) ! unit_truncate (dtp->u.p.current_unit, ! stell (dtp->u.p.current_unit->s), ! &dtp->common); dtp->u.p.current_unit->endfile = AT_ENDFILE; break; } free_format_data (dtp); free_ionml (dtp); if (dtp->u.p.current_unit != NULL) unlock_unit (dtp->u.p.current_unit); *************** void reverse_memcpy (void *dest, const v *** 3262,3264 **** --- 3422,3467 ---- for (i=0; iu.p.current_unit->flags.position = POSITION_APPEND; + + if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) + switch (dtp->u.p.current_unit->endfile) + { + case NO_ENDFILE: + case AT_ENDFILE: + generate_error (&dtp->common, LIBERROR_END, NULL); + if (!is_internal_unit (dtp)) + { + dtp->u.p.current_unit->endfile = AFTER_ENDFILE; + dtp->u.p.current_unit->current_record = 0; + } + else + dtp->u.p.current_unit->endfile = AT_ENDFILE; + break; + + case AFTER_ENDFILE: + generate_error (&dtp->common, LIBERROR_ENDFILE, NULL); + dtp->u.p.current_unit->current_record = 0; + break; + } + else + { + /* Non-sequential files don't have an ENDFILE record, so we + can't be at AFTER_ENDFILE. */ + dtp->u.p.current_unit->endfile = AT_ENDFILE; + generate_error (&dtp->common, LIBERROR_END, NULL); + dtp->u.p.current_unit->current_record = 0; + } + } diff -Nrcpad gcc-4.4.0/libgfortran/io/unit.c gcc-4.4.1/libgfortran/io/unit.c *** gcc-4.4.0/libgfortran/io/unit.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/unit.c Thu Jun 11 12:49:35 2009 *************** init_units (void) *** 535,540 **** --- 535,542 ---- u->file_len = strlen (stdin_name); u->file = get_mem (u->file_len); memmove (u->file, stdin_name, u->file_len); + + fbuf_init (u, 0); __gthread_mutex_unlock (&u->lock); } *************** close_unit_1 (gfc_unit *u, int locked) *** 619,625 **** if (u->previous_nonadvancing_write) finish_last_advance_record (u); ! rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE; u->closed = 1; if (!locked) --- 621,627 ---- if (u->previous_nonadvancing_write) finish_last_advance_record (u); ! rc = (u->s == NULL) ? 0 : sclose (u->s) == -1; u->closed = 1; if (!locked) *************** close_unit_1 (gfc_unit *u, int locked) *** 635,641 **** free_mem (u->file); u->file = NULL; u->file_len = 0; ! fbuf_destroy (u); if (!locked) --- 637,643 ---- free_mem (u->file); u->file = NULL; u->file_len = 0; ! fbuf_destroy (u); if (!locked) *************** close_units (void) *** 692,706 **** void update_position (gfc_unit *u) { ! if (file_position (u->s) == 0) u->flags.position = POSITION_REWIND; ! else if (file_length (u->s) == file_position (u->s)) u->flags.position = POSITION_APPEND; else u->flags.position = POSITION_ASIS; } /* filename_from_unit()-- If the unit_number exists, return a pointer to the name of the associated file, otherwise return the empty string. The caller must free memory allocated for the filename string. */ --- 694,755 ---- void update_position (gfc_unit *u) { ! if (stell (u->s) == 0) u->flags.position = POSITION_REWIND; ! else if (file_length (u->s) == stell (u->s)) u->flags.position = POSITION_APPEND; else u->flags.position = POSITION_ASIS; } + /* High level interface to truncate a file safely, i.e. flush format + buffers, check that it's a regular file, and generate error if that + occurs. Just like POSIX ftruncate, returns 0 on success, -1 on + failure. */ + + int + unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common) + { + int ret; + + /* Make sure format buffer is flushed. */ + if (u->flags.form == FORM_FORMATTED) + { + if (u->mode == READING) + pos += fbuf_reset (u); + else + fbuf_flush (u, u->mode); + } + + /* Don't try to truncate a special file, just pretend that it + succeeds. */ + if (is_special (u->s) || !is_seekable (u->s)) + { + sflush (u->s); + return 0; + } + + /* struncate() should flush the stream buffer if necessary, so don't + bother calling sflush() here. */ + ret = struncate (u->s, pos); + + if (ret != 0) + { + generate_error (common, LIBERROR_OS, NULL); + u->endfile = NO_ENDFILE; + u->flags.position = POSITION_ASIS; + } + else + { + u->endfile = AT_ENDFILE; + u->flags.position = POSITION_APPEND; + } + + return ret; + } + + /* filename_from_unit()-- If the unit_number exists, return a pointer to the name of the associated file, otherwise return the empty string. The caller must free memory allocated for the filename string. */ *************** finish_last_advance_record (gfc_unit *u) *** 741,763 **** { if (u->saved_pos > 0) ! fbuf_seek (u, u->saved_pos); ! ! fbuf_flush (u, 1); if (!(u->unit_number == options.stdout_unit || u->unit_number == options.stderr_unit)) { - size_t len; - - const char crlf[] = "\r\n"; #ifdef HAVE_CRLF ! len = 2; #else ! len = 1; #endif ! if (swrite (u->s, &crlf[2-len], &len) != 0) os_error ("Completing record after ADVANCE_NO failed"); } } --- 790,814 ---- { if (u->saved_pos > 0) ! fbuf_seek (u, u->saved_pos, SEEK_CUR); if (!(u->unit_number == options.stdout_unit || u->unit_number == options.stderr_unit)) { #ifdef HAVE_CRLF ! const int len = 2; #else ! const int len = 1; #endif ! char *p = fbuf_alloc (u, len); ! if (!p) os_error ("Completing record after ADVANCE_NO failed"); + #ifdef HAVE_CRLF + *(p++) = '\r'; + #endif + *p = '\n'; } + + fbuf_flush (u, u->mode); } diff -Nrcpad gcc-4.4.0/libgfortran/io/unix.c gcc-4.4.1/libgfortran/io/unix.c *** gcc-4.4.0/libgfortran/io/unix.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/unix.c Wed May 27 01:21:22 2009 *************** id_from_fd (const int fd) *** 89,98 **** #endif - #ifndef SSIZE_MAX - #define SSIZE_MAX SHRT_MAX - #endif - #ifndef PATH_MAX #define PATH_MAX 1024 #endif --- 89,94 ---- *************** id_from_fd (const int fd) *** 124,251 **** #endif ! /* Unix stream I/O module */ ! #define BUFFER_SIZE 8192 typedef struct { stream st; - int fd; gfc_offset buffer_offset; /* File offset of the start of the buffer */ gfc_offset physical_offset; /* Current physical file offset */ gfc_offset logical_offset; /* Current logical file offset */ - gfc_offset dirty_offset; /* Start of modified bytes in buffer */ gfc_offset file_length; /* Length of the file, -1 if not seekable. */ ! int len; /* Physical length of the current buffer */ ! int active; /* Length of valid bytes in the buffer */ ! ! int prot; ! int ndirty; /* Dirty bytes starting at dirty_offset */ ! ! int special_file; /* =1 if the fd refers to a special file */ ! ! io_mode method; /* Method of stream I/O being used */ ! ! char *buffer; ! char small_buffer[BUFFER_SIZE]; ! } ! unix_stream; ! ! ! /* Stream structure for internal files. Fields must be kept in sync ! with unix_stream above, except for the buffer. For internal files ! we point the buffer pointer directly at the destination memory. */ ! ! typedef struct ! { ! stream st; ! ! int fd; ! gfc_offset buffer_offset; /* File offset of the start of the buffer */ ! gfc_offset physical_offset; /* Current physical file offset */ ! gfc_offset logical_offset; /* Current logical file offset */ ! gfc_offset dirty_offset; /* Start of modified bytes in buffer */ ! gfc_offset file_length; /* Length of the file, -1 if not seekable. */ - int len; /* Physical length of the current buffer */ int active; /* Length of valid bytes in the buffer */ int prot; ! int ndirty; /* Dirty bytes starting at dirty_offset */ int special_file; /* =1 if the fd refers to a special file */ - - io_mode method; /* Method of stream I/O being used */ - - char *buffer; - } - int_stream; - - /* This implementation of stream I/O is based on the paper: - * - * "Exploiting the advantages of mapped files for stream I/O", - * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter - * USENIX conference", p. 27-42. - * - * It differs in a number of ways from the version described in the - * paper. First of all, threads are not an issue during I/O and we - * also don't have to worry about having multiple regions, since - * fortran's I/O model only allows you to be one place at a time. - * - * On the other hand, we have to be able to writing at the end of a - * stream, read from the start of a stream or read and write blocks of - * bytes from an arbitrary position. After opening a file, a pointer - * to a stream structure is returned, which is used to handle file - * accesses until the file is closed. - * - * salloc_at_r(stream, len, where)-- Given a stream pointer, return a - * pointer to a block of memory that mirror the file at position - * 'where' that is 'len' bytes long. The len integer is updated to - * reflect how many bytes were actually read. The only reason for a - * short read is end of file. The file pointer is updated. The - * pointer is valid until the next call to salloc_*. - * - * salloc_at_w(stream, len, where)-- Given the stream pointer, returns - * a pointer to a block of memory that is updated to reflect the state - * of the file. The length of the buffer is always equal to that - * requested. The buffer must be completely set by the caller. When - * data has been written, the sfree() function must be called to - * indicate that the caller is done writing data to the buffer. This - * may or may not cause a physical write. - * - * Short forms of these are salloc_r() and salloc_w() which drop the - * 'where' parameter and use the current file pointer. */ - - - /*move_pos_offset()-- Move the record pointer right or left - *relative to current position */ - - int - move_pos_offset (stream* st, int pos_off) - { - unix_stream * str = (unix_stream*)st; - if (pos_off < 0) - { - str->logical_offset += pos_off; - - if (str->dirty_offset + str->ndirty > str->logical_offset) - { - if (str->ndirty + pos_off > 0) - str->ndirty += pos_off; - else - { - str->dirty_offset += pos_off + pos_off; - str->ndirty = 0; - } - } - - return pos_off; - } - return 0; } /* fix_fd()-- Given a file descriptor, make sure it is not one of the --- 120,149 ---- #endif ! /* Unix and internal stream I/O module */ ! static const int BUFFER_SIZE = 8192; typedef struct { stream st; gfc_offset buffer_offset; /* File offset of the start of the buffer */ gfc_offset physical_offset; /* Current physical file offset */ gfc_offset logical_offset; /* Current logical file offset */ gfc_offset file_length; /* Length of the file, -1 if not seekable. */ ! char *buffer; /* Pointer to the buffer. */ ! int fd; /* The POSIX file descriptor. */ int active; /* Length of valid bytes in the buffer */ int prot; ! int ndirty; /* Dirty bytes starting at buffer_offset */ int special_file; /* =1 if the fd refers to a special file */ } + unix_stream; /* fix_fd()-- Given a file descriptor, make sure it is not one of the *************** fix_fd (int fd) *** 292,308 **** 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; - } /* If the stream corresponds to a preconnected unit, we flush the corresponding C stream. This is bugware for mixed C-Fortran codes --- 190,195 ---- *************** flush_if_preconnected (stream * s) *** 322,901 **** } ! /* Reset a stream after reading/writing. Assumes that the buffers have ! been flushed. */ ! inline static void ! reset_stream (unix_stream * s, size_t bytes_rw) { ! s->physical_offset += bytes_rw; ! s->logical_offset = s->physical_offset; ! if (s->file_length != -1 && s->physical_offset > s->file_length) ! s->file_length = s->physical_offset; } ! /* Read bytes into a buffer, allowing for short reads. If the nbytes ! * argument is less on return than on entry, it is because we've hit ! * the end of file. */ static int ! do_read (unix_stream * s, void * buf, size_t * nbytes) { ! ssize_t trans; ! size_t bytes_left; ! char *buf_st; ! int status; ! ! status = 0; ! bytes_left = *nbytes; ! buf_st = (char *) buf; ! ! /* We must read in a loop since some systems don't restart system ! calls in case of a signal. */ ! while (bytes_left > 0) ! { ! /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3, ! so we must read in chunks smaller than SSIZE_MAX. */ ! trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX; ! trans = read (s->fd, buf_st, trans); ! if (trans < 0) ! { ! if (errno == EINTR) ! continue; ! else ! { ! status = errno; ! break; ! } ! } ! else if (trans == 0) /* We hit EOF. */ ! break; ! buf_st += trans; ! bytes_left -= trans; ! } ! ! *nbytes -= bytes_left; ! return status; } ! /* Write a buffer to a stream, allowing for short writes. */ ! ! static int ! do_write (unix_stream * s, const void * buf, size_t * nbytes) { ! ssize_t trans; ! size_t bytes_left; char *buf_st; - int status; ! status = 0; ! bytes_left = *nbytes; buf_st = (char *) buf; /* We must write in a loop since some systems don't restart system calls in case of a signal. */ while (bytes_left > 0) { ! /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3, ! so we must write in chunks smaller than SSIZE_MAX. */ ! trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX; ! trans = write (s->fd, buf_st, trans); if (trans < 0) { if (errno == EINTR) continue; else ! { ! status = errno; ! break; ! } } buf_st += trans; bytes_left -= trans; } ! *nbytes -= bytes_left; ! return status; } ! /* get_oserror()-- Get the most recent operating system error. For ! * unix, this is errno. */ ! const char * ! get_oserror (void) { ! return strerror (errno); } ! /********************************************************************* ! File descriptor stream functions ! *********************************************************************/ - /* fd_flush()-- Write bytes that need to be written */ ! static try ! fd_flush (unix_stream * s) { ! size_t writelen; if (s->ndirty == 0) ! return SUCCESS; ! if (s->file_length != -1 && s->physical_offset != s->dirty_offset && ! lseek (s->fd, s->dirty_offset, SEEK_SET) < 0) ! return FAILURE; ! writelen = s->ndirty; ! if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset), ! &writelen) != 0) ! return FAILURE; ! s->physical_offset = s->dirty_offset + writelen; ! /* don't increment file_length if the file is non-seekable */ if (s->file_length != -1 && s->physical_offset > s->file_length) ! s->file_length = s->physical_offset; s->ndirty -= writelen; if (s->ndirty != 0) ! return FAILURE; ! return SUCCESS; } ! ! /* fd_alloc()-- Arrange a buffer such that the salloc() request can be ! * satisfied. This subroutine gets the buffer ready for whatever is ! * to come next. */ ! ! static void ! fd_alloc (unix_stream * s, gfc_offset where, ! int *len __attribute__ ((unused))) { ! char *new_buffer; ! int n, read_len; ! if (*len <= BUFFER_SIZE) ! { ! new_buffer = s->small_buffer; ! read_len = BUFFER_SIZE; ! } else { ! new_buffer = get_mem (*len); ! read_len = *len; ! } ! ! /* Salvage bytes currently within the buffer. This is important for ! * devices that cannot seek. */ ! ! if (s->buffer != NULL && s->buffer_offset <= where && ! where <= s->buffer_offset + s->active) ! { ! ! n = s->active - (where - s->buffer_offset); ! memmove (new_buffer, s->buffer + (where - s->buffer_offset), n); ! ! s->active = n; ! } ! else ! { /* new buffer starts off empty */ ! s->active = 0; } ! ! s->buffer_offset = where; ! ! /* free the old buffer if necessary */ ! ! if (s->buffer != NULL && s->buffer != s->small_buffer) ! free_mem (s->buffer); ! ! s->buffer = new_buffer; ! s->len = read_len; } ! ! /* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either ! * we've already buffered the data or we need to load it. Returns ! * NULL on I/O error. */ ! ! static char * ! fd_alloc_r_at (unix_stream * s, int *len) { ! gfc_offset m; ! gfc_offset where = s->logical_offset; ! ! if (s->buffer != NULL && s->buffer_offset <= where && ! where + *len <= s->buffer_offset + s->active) ! { ! ! /* Return a position within the current buffer */ ! ! s->logical_offset = where + *len; ! return s->buffer + where - s->buffer_offset; ! } ! ! fd_alloc (s, where, len); ! ! m = where + s->active; ! ! if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0) ! return NULL; ! ! /* do_read() hangs on read from terminals for *BSD-systems. Only ! use read() in that case. */ ! if (s->special_file) { ! ssize_t n; ! ! n = read (s->fd, s->buffer + s->active, s->len - s->active); ! if (n < 0) ! return NULL; ! ! s->physical_offset = m + n; ! s->active += n; } else { ! size_t n; ! ! n = s->len - s->active; ! if (do_read (s, s->buffer + s->active, &n) != 0) ! return NULL; ! ! s->physical_offset = m + n; ! s->active += n; ! } ! ! if (s->active < *len) ! *len = s->active; /* Bytes actually available */ ! ! s->logical_offset = where + *len; ! ! return s->buffer; ! } ! ! ! /* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either ! * we've already buffered the data or we need to load it. */ ! ! static char * ! fd_alloc_w_at (unix_stream * s, int *len) ! { ! gfc_offset n; ! gfc_offset where = s->logical_offset; ! ! if (s->buffer == NULL || s->buffer_offset > where || ! where + *len > s->buffer_offset + s->len) ! { ! ! if (fd_flush (s) == FAILURE) ! return NULL; ! fd_alloc (s, where, len); ! } ! ! /* Return a position within the current buffer */ ! if (s->ndirty == 0 ! || where > s->dirty_offset + s->ndirty ! || s->dirty_offset > where + *len) ! { /* Discontiguous blocks, start with a clean buffer. */ ! /* Flush the buffer. */ ! if (s->ndirty != 0) ! fd_flush (s); ! s->dirty_offset = where; ! s->ndirty = *len; ! } ! else ! { ! gfc_offset start; /* Merge with the existing data. */ ! if (where < s->dirty_offset) ! start = where; ! else ! start = s->dirty_offset; ! if (where + *len > s->dirty_offset + s->ndirty) ! s->ndirty = where + *len - start; ! else ! s->ndirty = s->dirty_offset + s->ndirty - start; ! s->dirty_offset = start; } ! ! s->logical_offset = where + *len; ! /* Don't increment file_length if the file is non-seekable. */ - if (s->file_length != -1 && s->logical_offset > s->file_length) ! s->file_length = s->logical_offset; ! ! n = s->logical_offset - s->buffer_offset; ! if (n > s->active) ! s->active = n; ! ! return s->buffer + where - s->buffer_offset; ! } ! ! ! static try ! fd_sfree (unix_stream * s) ! { ! if (s->ndirty != 0 && ! (s->buffer != s->small_buffer || options.all_unbuffered || ! s->method == SYNC_UNBUFFERED)) ! return fd_flush (s); ! ! return SUCCESS; ! } ! ! ! static try ! fd_seek (unix_stream * s, gfc_offset offset) ! { ! ! if (s->file_length == -1) ! return SUCCESS; ! ! if (s->physical_offset == offset) /* Are we lucky and avoid syscall? */ ! { ! s->logical_offset = offset; ! return SUCCESS; ! } ! ! if (lseek (s->fd, offset, SEEK_SET) >= 0) ! { ! s->physical_offset = s->logical_offset = offset; ! s->active = 0; ! return SUCCESS; ! } ! ! return FAILURE; } ! ! /* truncate_file()-- Given a unit, truncate the file at the current ! * position. Sets the physical location to the new end of the file. ! * Returns nonzero on error. */ ! ! static try ! fd_truncate (unix_stream * s) { ! /* Non-seekable files, like terminals and fifo's fail the lseek so just ! return success, there is nothing to truncate. If its not a pipe there ! is a real problem. */ ! if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1) { ! if (errno == ESPIPE) ! return SUCCESS; ! else ! return FAILURE; } ! ! /* Using ftruncate on a seekable special file (like /dev/null) ! is undefined, so we treat it as if the ftruncate succeeded. */ ! if (!s->special_file ! && ( ! #ifdef HAVE_FTRUNCATE ! ftruncate (s->fd, s->logical_offset) != 0 ! #elif defined HAVE_CHSIZE ! chsize (s->fd, s->logical_offset) != 0 ! #else ! /* If we have neither, always fail and exit, noisily. */ ! runtime_error ("required ftruncate or chsize support not present"), 1 ! #endif ! )) { ! /* The truncation failed and we need to handle this gracefully. ! The file length remains the same, but the file-descriptor ! offset needs adjustment per the successful lseek above. ! (Similarly, the contents of the buffer isn't valid anymore.) ! A ftruncate call does not affect the physical (file-descriptor) ! offset, according to the ftruncate manual, so neither should a ! failed call. */ ! s->physical_offset = s->logical_offset; ! s->active = 0; ! return FAILURE; } ! ! s->physical_offset = s->file_length = s->logical_offset; ! s->active = 0; ! return SUCCESS; } ! ! /* Similar to memset(), but operating on a stream instead of a string. ! Takes care of not using too much memory. */ ! ! static try ! fd_sset (unix_stream * s, int c, size_t n) { ! size_t bytes_left; ! int trans; ! void *p; ! ! bytes_left = n; ! ! while (bytes_left > 0) ! { ! /* memset() in chunks of BUFFER_SIZE. */ ! trans = (bytes_left < BUFFER_SIZE) ? bytes_left : BUFFER_SIZE; ! ! p = fd_alloc_w_at (s, &trans); ! if (p) ! memset (p, c, trans); ! else ! return FAILURE; ! ! bytes_left -= trans; ! } ! ! return SUCCESS; } - - /* Stream read function. Avoids using a buffer for big reads. The - interface is like POSIX read(), but the nbytes argument is a - pointer; on return it contains the number of bytes written. The - function return value is the status indicator (0 for success). */ - static int ! fd_read (unix_stream * s, void * buf, size_t * nbytes) { ! void *p; ! int tmp, status; ! ! if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED) ! { ! tmp = *nbytes; ! p = fd_alloc_r_at (s, &tmp); ! if (p) ! { ! *nbytes = tmp; ! memcpy (buf, p, *nbytes); ! return 0; ! } ! else ! { ! *nbytes = 0; ! return errno; ! } ! } ! ! /* If the request is bigger than BUFFER_SIZE we flush the buffers ! and read directly. */ ! if (fd_flush (s) == FAILURE) ! { ! *nbytes = 0; ! return errno; ! } ! ! if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE) ! { ! *nbytes = 0; ! return errno; ! } ! status = do_read (s, buf, nbytes); ! reset_stream (s, *nbytes); ! return status; } - - /* Stream write function. Avoids using a buffer for big writes. The - interface is like POSIX write(), but the nbytes argument is a - pointer; on return it contains the number of bytes written. The - function return value is the status indicator (0 for success). */ - static int ! fd_write (unix_stream * s, const void * buf, size_t * nbytes) ! { ! void *p; ! int tmp, status; ! ! if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED) ! { ! tmp = *nbytes; ! p = fd_alloc_w_at (s, &tmp); ! if (p) ! { ! *nbytes = tmp; ! memcpy (p, buf, *nbytes); ! return 0; ! } ! else ! { ! *nbytes = 0; ! return errno; ! } ! } ! ! /* If the request is bigger than BUFFER_SIZE we flush the buffers ! and write directly. */ ! if (fd_flush (s) == FAILURE) ! { ! *nbytes = 0; ! return errno; ! } ! ! if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE) ! { ! *nbytes = 0; ! return errno; ! } ! ! status = do_write (s, buf, nbytes); ! reset_stream (s, *nbytes); ! return status; ! } ! ! ! static try ! fd_close (unix_stream * s) { ! if (fd_flush (s) == FAILURE) ! return FAILURE; ! ! if (s->buffer != NULL && s->buffer != s->small_buffer) ! free_mem (s->buffer); ! ! if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO && s->fd != STDIN_FILENO) ! { ! if (close (s->fd) < 0) ! return FAILURE; ! } ! ! free_mem (s); ! ! return SUCCESS; } ! ! static void ! fd_open (unix_stream * s) { ! if (isatty (s->fd)) ! s->method = SYNC_UNBUFFERED; ! else ! s->method = SYNC_BUFFERED; ! ! s->st.alloc_w_at = (void *) fd_alloc_w_at; ! s->st.sfree = (void *) fd_sfree; ! s->st.close = (void *) fd_close; ! s->st.seek = (void *) fd_seek; ! s->st.trunc = (void *) fd_truncate; ! s->st.read = (void *) fd_read; ! s->st.write = (void *) fd_write; ! s->st.set = (void *) fd_sset; ! s->buffer = NULL; } - - /********************************************************************* memory stream functions - These are used for internal files --- 209,543 ---- } ! /* get_oserror()-- Get the most recent operating system error. For ! * unix, this is errno. */ ! const char * ! get_oserror (void) { ! return strerror (errno); } ! /******************************************************************** ! Raw I/O functions (read, write, seek, tell, truncate, close). ! ! These functions wrap the basic POSIX I/O syscalls. Any deviation in ! semantics is a bug, except the following: write restarts in case ! of being interrupted by a signal, and as the first argument the ! functions take the unix_stream struct rather than an integer file ! descriptor. Also, for POSIX read() and write() a nbyte argument larger ! than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather ! than size_t as for POSIX read/write. ! *********************************************************************/ static int ! raw_flush (unix_stream * s __attribute__ ((unused))) { ! return 0; } + static ssize_t + raw_read (unix_stream * s, void * buf, ssize_t nbyte) + { + /* For read we can't do I/O in a loop like raw_write does, because + that will break applications that wait for interactive I/O. */ + return read (s->fd, buf, nbyte); + } ! static ssize_t ! raw_write (unix_stream * s, const void * buf, ssize_t nbyte) { ! ssize_t trans, bytes_left; char *buf_st; ! bytes_left = nbyte; buf_st = (char *) buf; /* We must write in a loop since some systems don't restart system calls in case of a signal. */ while (bytes_left > 0) { ! trans = write (s->fd, buf_st, bytes_left); if (trans < 0) { if (errno == EINTR) continue; else ! return trans; } buf_st += trans; bytes_left -= trans; } ! return nbyte - bytes_left; } + static off_t + raw_seek (unix_stream * s, off_t offset, int whence) + { + return lseek (s->fd, offset, whence); + } ! static off_t ! raw_tell (unix_stream * s) ! { ! return lseek (s->fd, 0, SEEK_CUR); ! } ! static int ! raw_truncate (unix_stream * s, off_t length) { ! #ifdef HAVE_FTRUNCATE ! return ftruncate (s->fd, length); ! #elif defined HAVE_CHSIZE ! return chsize (s->fd, length); ! #else ! runtime_error ("required ftruncate or chsize support not present"); ! return -1; ! #endif } + static int + raw_close (unix_stream * s) + { + int retval; + + if (s->fd != STDOUT_FILENO + && s->fd != STDERR_FILENO + && s->fd != STDIN_FILENO) + retval = close (s->fd); + else + retval = 0; + free_mem (s); + return retval; + } ! static int ! raw_init (unix_stream * s) ! { ! s->st.read = (void *) raw_read; ! s->st.write = (void *) raw_write; ! s->st.seek = (void *) raw_seek; ! s->st.tell = (void *) raw_tell; ! s->st.trunc = (void *) raw_truncate; ! s->st.close = (void *) raw_close; ! s->st.flush = (void *) raw_flush; + s->buffer = NULL; + return 0; + } ! /********************************************************************* ! Buffered I/O functions. These functions have the same semantics as the ! raw I/O functions above, except that they are buffered in order to ! improve performance. The buffer must be flushed when switching from ! reading to writing and vice versa. ! *********************************************************************/ ! ! static int ! buf_flush (unix_stream * s) { ! int writelen; ! ! /* Flushing in read mode means discarding read bytes. */ ! s->active = 0; if (s->ndirty == 0) ! return 0; ! if (s->file_length != -1 && s->physical_offset != s->buffer_offset ! && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0) ! return -1; ! writelen = raw_write (s, s->buffer, s->ndirty); ! s->physical_offset = s->buffer_offset + writelen; ! /* Don't increment file_length if the file is non-seekable. */ if (s->file_length != -1 && s->physical_offset > s->file_length) ! s->file_length = s->physical_offset; s->ndirty -= writelen; if (s->ndirty != 0) ! return -1; ! return 0; } ! static ssize_t ! buf_read (unix_stream * s, void * buf, ssize_t nbyte) { ! if (s->active == 0) ! s->buffer_offset = s->logical_offset; ! /* Is the data we want in the buffer? */ ! if (s->logical_offset + nbyte <= s->buffer_offset + s->active ! && s->buffer_offset <= s->logical_offset) ! memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte); else { ! /* First copy the active bytes if applicable, then read the rest ! either directly or filling the buffer. */ ! char *p; ! int nread = 0; ! ssize_t to_read, did_read; ! gfc_offset new_logical; ! ! p = (char *) buf; ! if (s->logical_offset >= s->buffer_offset ! && s->buffer_offset + s->active >= s->logical_offset) ! { ! nread = s->active - (s->logical_offset - s->buffer_offset); ! memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), ! nread); ! p += nread; ! } ! /* At this point we consider all bytes in the buffer discarded. */ ! to_read = nbyte - nread; ! new_logical = s->logical_offset + nread; ! if (s->file_length != -1 && s->physical_offset != new_logical ! && lseek (s->fd, new_logical, SEEK_SET) < 0) ! return -1; ! s->buffer_offset = s->physical_offset = new_logical; ! if (to_read <= BUFFER_SIZE/2) ! { ! did_read = raw_read (s, s->buffer, BUFFER_SIZE); ! s->physical_offset += did_read; ! s->active = did_read; ! did_read = (did_read > to_read) ? to_read : did_read; ! memcpy (p, s->buffer, did_read); ! } ! else ! { ! did_read = raw_read (s, p, to_read); ! s->physical_offset += did_read; ! s->active = 0; ! } ! nbyte = did_read + nread; } ! s->logical_offset += nbyte; ! return nbyte; } ! static ssize_t ! buf_write (unix_stream * s, const void * buf, ssize_t nbyte) { ! if (s->ndirty == 0) ! s->buffer_offset = s->logical_offset; ! /* Does the data fit into the buffer? As a special case, if the ! buffer is empty and the request is bigger than BUFFER_SIZE/2, ! write directly. This avoids the case where the buffer would have ! to be flushed at every write. */ ! if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2) ! && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE ! && s->buffer_offset <= s->logical_offset ! && s->buffer_offset + s->ndirty >= s->logical_offset) { ! memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte); ! int nd = (s->logical_offset - s->buffer_offset) + nbyte; ! if (nd > s->ndirty) ! s->ndirty = nd; } else { ! /* Flush, and either fill the buffer with the new data, or if ! the request is bigger than the buffer size, write directly ! bypassing the buffer. */ ! buf_flush (s); ! if (nbyte <= BUFFER_SIZE/2) ! { ! memcpy (s->buffer, buf, nbyte); ! s->buffer_offset = s->logical_offset; ! s->ndirty += nbyte; ! } ! else ! { ! if (s->file_length != -1 && s->physical_offset != s->logical_offset ! && lseek (s->fd, s->logical_offset, SEEK_SET) < 0) ! return -1; ! nbyte = raw_write (s, buf, nbyte); ! s->physical_offset += nbyte; ! } } ! s->logical_offset += nbyte; /* Don't increment file_length if the file is non-seekable. */ if (s->file_length != -1 && s->logical_offset > s->file_length) ! s->file_length = s->logical_offset; ! return nbyte; } ! static off_t ! buf_seek (unix_stream * s, off_t offset, int whence) { ! switch (whence) { ! case SEEK_SET: ! break; ! case SEEK_CUR: ! offset += s->logical_offset; ! break; ! case SEEK_END: ! offset += s->file_length; ! break; ! default: ! return -1; } ! if (offset < 0) { ! errno = EINVAL; ! return -1; } ! s->logical_offset = offset; ! return offset; } ! static off_t ! buf_tell (unix_stream * s) { ! return s->logical_offset; } static int ! buf_truncate (unix_stream * s, off_t length) { ! int r; ! if (buf_flush (s) != 0) ! return -1; ! r = raw_truncate (s, length); ! if (r == 0) ! s->file_length = length; ! return r; } static int ! buf_close (unix_stream * s) { ! if (buf_flush (s) != 0) ! return -1; ! free_mem (s->buffer); ! return raw_close (s); } ! static int ! buf_init (unix_stream * s) { ! s->st.read = (void *) buf_read; ! s->st.write = (void *) buf_write; ! s->st.seek = (void *) buf_seek; ! s->st.tell = (void *) buf_tell; ! s->st.trunc = (void *) buf_truncate; ! s->st.close = (void *) buf_close; ! s->st.flush = (void *) buf_flush; ! s->buffer = get_mem (BUFFER_SIZE); ! return 0; } /********************************************************************* memory stream functions - These are used for internal files *************** fd_open (unix_stream * s) *** 907,939 **** *********************************************************************/ ! static char * ! mem_alloc_r_at (int_stream * s, int *len) { gfc_offset n; gfc_offset where = s->logical_offset; if (where < s->buffer_offset || where > s->buffer_offset + s->active) return NULL; - s->logical_offset = where + *len; - n = s->buffer_offset + s->active - where; if (*len > n) *len = n; return s->buffer + (where - s->buffer_offset); } ! static char * ! mem_alloc_w_at (int_stream * s, int *len) { gfc_offset m; gfc_offset where = s->logical_offset; - assert (*len >= 0); /* Negative values not allowed. */ - m = where + *len; if (where < s->buffer_offset) --- 549,581 ---- *********************************************************************/ ! char * ! mem_alloc_r (stream * strm, int * len) { + unix_stream * s = (unix_stream *) strm; gfc_offset n; gfc_offset where = s->logical_offset; if (where < s->buffer_offset || where > s->buffer_offset + s->active) return NULL; n = s->buffer_offset + s->active - where; if (*len > n) *len = n; + s->logical_offset = where + *len; + return s->buffer + (where - s->buffer_offset); } ! char * ! mem_alloc_w (stream * strm, int * len) { + unix_stream * s = (unix_stream *) strm; gfc_offset m; gfc_offset where = s->logical_offset; m = where + *len; if (where < s->buffer_offset) *************** mem_alloc_w_at (int_stream * s, int *len *** 950,974 **** /* Stream read function for internal units. */ ! static int ! mem_read (int_stream * s, void * buf, size_t * nbytes) { void *p; ! int tmp; ! tmp = *nbytes; ! p = mem_alloc_r_at (s, &tmp); if (p) { ! *nbytes = tmp; ! memcpy (buf, p, *nbytes); ! return 0; } else ! { ! *nbytes = 0; ! return 0; ! } } --- 592,611 ---- /* Stream read function for internal units. */ ! static ssize_t ! mem_read (stream * s, void * buf, ssize_t nbytes) { void *p; ! int nb = nbytes; ! p = mem_alloc_r (s, &nb); if (p) { ! memcpy (buf, p, nb); ! return (ssize_t) nb; } else ! return 0; } *************** mem_read (int_stream * s, void * buf, si *** 976,1059 **** at the moment, as all internal IO is formatted and the formatted IO routines use mem_alloc_w_at. */ ! static int ! mem_write (int_stream * s, const void * buf, size_t * nbytes) { void *p; ! int tmp; ! tmp = *nbytes; ! p = mem_alloc_w_at (s, &tmp); if (p) { ! *nbytes = tmp; ! memcpy (p, buf, *nbytes); ! return 0; } else ! { ! *nbytes = 0; ! return 0; ! } } ! static int ! mem_seek (int_stream * s, gfc_offset offset) { if (offset > s->file_length) { ! errno = ESPIPE; ! return FAILURE; } s->logical_offset = offset; ! return SUCCESS; } ! static try ! mem_set (int_stream * s, int c, size_t n) { ! void *p; ! int len; ! ! len = n; ! ! p = mem_alloc_w_at (s, &len); ! if (p) ! { ! memset (p, c, len); ! return SUCCESS; ! } ! else ! return FAILURE; } static int ! mem_truncate (int_stream * s __attribute__ ((unused))) { ! return SUCCESS; } ! static try ! mem_close (int_stream * s) { ! if (s != NULL) ! free_mem (s); ! ! return SUCCESS; } ! static try ! mem_sfree (int_stream * s __attribute__ ((unused))) { ! return SUCCESS; ! } /********************************************************************* --- 613,702 ---- at the moment, as all internal IO is formatted and the formatted IO routines use mem_alloc_w_at. */ ! static ssize_t ! mem_write (stream * s, const void * buf, ssize_t nbytes) { void *p; ! int nb = nbytes; ! p = mem_alloc_w (s, &nb); if (p) { ! memcpy (p, buf, nb); ! return (ssize_t) nb; } else ! return 0; } ! static off_t ! mem_seek (stream * strm, off_t offset, int whence) { + unix_stream * s = (unix_stream *) strm; + switch (whence) + { + case SEEK_SET: + break; + case SEEK_CUR: + offset += s->logical_offset; + break; + case SEEK_END: + offset += s->file_length; + break; + default: + return -1; + } + + /* Note that for internal array I/O it's actually possible to have a + negative offset, so don't check for that. */ if (offset > s->file_length) { ! errno = EINVAL; ! return -1; } s->logical_offset = offset; ! ! /* Returning < 0 is the error indicator for sseek(), so return 0 if ! offset is negative. Thus if the return value is 0, the caller ! has to use stell() to get the real value of logical_offset. */ ! if (offset >= 0) ! return offset; ! return 0; } ! static off_t ! mem_tell (stream * s) { ! return ((unix_stream *)s)->logical_offset; } static int ! mem_truncate (unix_stream * s __attribute__ ((unused)), ! off_t length __attribute__ ((unused))) { ! return 0; } ! static int ! mem_flush (unix_stream * s __attribute__ ((unused))) { ! return 0; } ! static int ! mem_close (unix_stream * s) { ! if (s != NULL) ! free_mem (s); + return 0; + } /********************************************************************* *************** mem_sfree (int_stream * s __attribute__ *** 1066,1072 **** void empty_internal_buffer(stream *strm) { ! int_stream * s = (int_stream *) strm; memset(s->buffer, ' ', s->file_length); } --- 709,715 ---- void empty_internal_buffer(stream *strm) { ! unix_stream * s = (unix_stream *) strm; memset(s->buffer, ' ', s->file_length); } *************** empty_internal_buffer(stream *strm) *** 1075,1084 **** stream * open_internal (char *base, int length, gfc_offset offset) { ! int_stream *s; ! s = get_mem (sizeof (int_stream)); ! memset (s, '\0', sizeof (int_stream)); s->buffer = base; s->buffer_offset = offset; --- 718,727 ---- stream * open_internal (char *base, int length, gfc_offset offset) { ! unix_stream *s; ! s = get_mem (sizeof (unix_stream)); ! memset (s, '\0', sizeof (unix_stream)); s->buffer = base; s->buffer_offset = offset; *************** open_internal (char *base, int length, g *** 1086,1099 **** s->logical_offset = 0; s->active = s->file_length = length; - s->st.alloc_w_at = (void *) mem_alloc_w_at; - s->st.sfree = (void *) mem_sfree; s->st.close = (void *) mem_close; s->st.seek = (void *) mem_seek; s->st.trunc = (void *) mem_truncate; s->st.read = (void *) mem_read; s->st.write = (void *) mem_write; ! s->st.set = (void *) mem_set; return (stream *) s; } --- 729,741 ---- s->logical_offset = 0; s->active = s->file_length = length; s->st.close = (void *) mem_close; s->st.seek = (void *) mem_seek; + s->st.tell = (void *) mem_tell; s->st.trunc = (void *) mem_truncate; s->st.read = (void *) mem_read; s->st.write = (void *) mem_write; ! s->st.flush = (void *) mem_flush; return (stream *) s; } *************** fd_to_stream (int fd, int prot) *** 1128,1134 **** s->special_file = !S_ISREG (statbuf.st_mode); ! fd_open (s); return (stream *) s; } --- 770,783 ---- s->special_file = !S_ISREG (statbuf.st_mode); ! if (isatty (s->fd) || options.all_unbuffered ! ||(options.unbuffered_preconnected && ! (s->fd == STDIN_FILENO ! || s->fd == STDOUT_FILENO ! || s->fd == STDERR_FILENO))) ! raw_init (s); ! else ! buf_init (s); return (stream *) s; } *************** output_stream (void) *** 1412,1419 **** #endif s = fd_to_stream (STDOUT_FILENO, PROT_WRITE); - if (options.unbuffered_preconnected) - ((unix_stream *) s)->method = SYNC_UNBUFFERED; return s; } --- 1061,1066 ---- *************** error_stream (void) *** 1431,1438 **** #endif s = fd_to_stream (STDERR_FILENO, PROT_WRITE); - if (options.unbuffered_preconnected) - ((unix_stream *) s)->method = SYNC_UNBUFFERED; return s; } --- 1078,1083 ---- *************** flush_all_units_1 (gfc_unit *u, int min_ *** 1663,1669 **** if (__gthread_mutex_trylock (&u->lock)) return u; if (u->s) ! flush (u->s); __gthread_mutex_unlock (&u->lock); } u = u->right; --- 1308,1314 ---- if (__gthread_mutex_trylock (&u->lock)) return u; if (u->s) ! sflush (u->s); __gthread_mutex_unlock (&u->lock); } u = u->right; *************** flush_all_units (void) *** 1693,1699 **** if (u->closed == 0) { ! flush (u->s); __gthread_mutex_lock (&unit_lock); __gthread_mutex_unlock (&u->lock); (void) predec_waiting_locked (u); --- 1338,1344 ---- if (u->closed == 0) { ! sflush (u->s); __gthread_mutex_lock (&unit_lock); __gthread_mutex_unlock (&u->lock); (void) predec_waiting_locked (u); *************** flush_all_units (void) *** 1710,1749 **** } - /* stream_at_bof()-- Returns nonzero if the stream is at the beginning - * of the file. */ - - int - stream_at_bof (stream * s) - { - unix_stream *us; - - if (!is_seekable (s)) - return 0; - - us = (unix_stream *) s; - - return us->logical_offset == 0; - } - - - /* stream_at_eof()-- Returns nonzero if the stream is at the end - * of the file. */ - - int - stream_at_eof (stream * s) - { - unix_stream *us; - - if (!is_seekable (s)) - return 0; - - us = (unix_stream *) s; - - return us->logical_offset == us->dirty_offset; - } - - /* delete_file()-- Given a unit structure, delete the file associated * with the unit. Returns nonzero if something went wrong. */ --- 1355,1360 ---- *************** inquire_readwrite (const char *string, i *** 1949,1964 **** gfc_offset file_length (stream * s) { ! return ((unix_stream *) s)->file_length; ! } ! ! ! /* file_position()-- Return the current position of the file */ ! ! gfc_offset ! file_position (stream *s) ! { ! return ((unix_stream *) s)->logical_offset; } --- 1560,1574 ---- gfc_offset file_length (stream * s) { ! off_t curr, end; ! if (!is_seekable (s)) ! return -1; ! curr = stell (s); ! if (curr == -1) ! return curr; ! end = sseek (s, 0, SEEK_END); ! sseek (s, curr, SEEK_SET); ! return end; } *************** is_special (stream *s) *** 1983,1994 **** } - try - flush (stream *s) - { - return fd_flush( (unix_stream *) s); - } - int stream_isatty (stream *s) { --- 1593,1598 ---- *************** stream_ttyname (stream *s __attribute__ *** 2005,2016 **** #endif } - gfc_offset - stream_offset (stream *s) - { - return (((unix_stream *) s)->logical_offset); - } - /* How files are stored: This is an operating-system specific issue, and therefore belongs here. There are three cases to consider. --- 1609,1614 ---- diff -Nrcpad gcc-4.4.0/libgfortran/io/write.c gcc-4.4.1/libgfortran/io/write.c *** gcc-4.4.0/libgfortran/io/write.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/write.c Wed May 27 01:21:22 2009 *************** write_utf8_char4 (st_parameter_dt *dtp, *** 108,114 **** gfc_char4_t c; static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE }; ! size_t nbytes; uchar buf[6], d, *q; /* Take care of preceding blanks. */ --- 108,114 ---- gfc_char4_t c; static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE }; ! int nbytes; uchar buf[6], d, *q; /* Take care of preceding blanks. */ *************** write_decimal (st_parameter_dt *dtp, con *** 597,603 **** n = -n; nsign = sign == S_NONE ? 0 : 1; ! /* conv calls gfc_itoa which sets the negative sign needed by write_integer. The sign '+' or '-' is set below based on sign calculated above, so we just point past the sign in the string before proceeding to avoid double signs in corner cases. --- 597,603 ---- n = -n; nsign = sign == S_NONE ? 0 : 1; ! /* conv calls itoa which sets the negative sign needed by write_integer. The sign '+' or '-' is set below based on sign calculated above, so we just point past the sign in the string before proceeding to avoid double signs in corner cases. *************** btoa (GFC_UINTEGER_LARGEST n, char *buff *** 707,712 **** --- 707,754 ---- } + /* gfc_itoa()-- Integer to decimal conversion. + The itoa function is a widespread non-standard extension to standard + C, often declared in . Even though the itoa defined here + is a static function we take care not to conflict with any prior + non-static declaration. Hence the 'gfc_' prefix, which is normally + reserved for functions with external linkage. */ + + static const char * + gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len) + { + int negative; + char *p; + GFC_UINTEGER_LARGEST t; + + assert (len >= GFC_ITOA_BUF_SIZE); + + if (n == 0) + return "0"; + + negative = 0; + t = n; + if (n < 0) + { + negative = 1; + t = -n; /*must use unsigned to protect from overflow*/ + } + + p = buffer + GFC_ITOA_BUF_SIZE - 1; + *p = '\0'; + + while (t != 0) + { + *--p = '0' + (t % 10); + t /= 10; + } + + if (negative) + *--p = '-'; + return p; + } + + void write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len) { *************** write_o (st_parameter_dt *dtp, const fno *** 730,736 **** void write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len) { ! write_int (dtp, f, p, len, xtoa); } --- 772,778 ---- void write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len) { ! write_int (dtp, f, p, len, gfc_xtoa); } *************** write_x (st_parameter_dt *dtp, int len, *** 779,786 **** p = write_block (dtp, len); if (p == NULL) return; ! ! if (nspaces > 0) memset (&p[len - nspaces], ' ', nspaces); } --- 821,827 ---- p = write_block (dtp, len); if (p == NULL) return; ! if (nspaces > 0 && len - nspaces >= 0) memset (&p[len - nspaces], ' ', nspaces); } *************** namelist_write_newline (st_parameter_dt *** 1168,1174 **** /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; ! if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; --- 1209,1215 ---- /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; ! if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; *************** nml_write_obj (st_parameter_dt *dtp, nam *** 1189,1201 **** int rep_ctr; int num; int nml_carry; ! index_type len; index_type obj_size; index_type nelem; ! index_type dim_i; ! index_type clen; index_type elem_ctr; ! index_type obj_name_len; void * p ; char cup; char * obj_name; --- 1230,1242 ---- int rep_ctr; int num; int nml_carry; ! int len; index_type obj_size; index_type nelem; ! size_t dim_i; ! size_t clen; index_type elem_ctr; ! size_t obj_name_len; void * p ; char cup; char * obj_name; *************** nml_write_obj (st_parameter_dt *dtp, nam *** 1225,1238 **** len = 0; if (base) { ! len =strlen (base->var_name); ! for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++) { cup = toupper (base_name[dim_i]); write_character (dtp, &cup, 1, 1); } } ! for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++) { cup = toupper (obj->var_name[dim_i]); write_character (dtp, &cup, 1, 1); --- 1266,1281 ---- len = 0; if (base) { ! len = strlen (base->var_name); ! base_name_len = strlen (base_name); ! for (dim_i = 0; dim_i < base_name_len; dim_i++) { cup = toupper (base_name[dim_i]); write_character (dtp, &cup, 1, 1); } } ! clen = strlen (obj->var_name); ! for (dim_i = len; dim_i < clen; dim_i++) { cup = toupper (obj->var_name[dim_i]); write_character (dtp, &cup, 1, 1); *************** nml_write_obj (st_parameter_dt *dtp, nam *** 1271,1277 **** /* Set the index vector and count the number of elements. */ nelem = 1; ! for (dim_i=0; dim_i < obj->var_rank; dim_i++) { obj->ls[dim_i].idx = obj->dim[dim_i].lbound; nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound); --- 1314,1320 ---- /* Set the index vector and count the number of elements. */ nelem = 1; ! for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++) { obj->ls[dim_i].idx = obj->dim[dim_i].lbound; nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound); *************** nml_write_obj (st_parameter_dt *dtp, nam *** 1374,1380 **** /* Append the qualifier. */ tot_len = base_name_len + clen; ! for (dim_i = 0; dim_i < obj->var_rank; dim_i++) { if (!dim_i) { --- 1417,1423 ---- /* Append the qualifier. */ tot_len = base_name_len + clen; ! for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++) { if (!dim_i) { *************** nml_write_obj (st_parameter_dt *dtp, nam *** 1383,1389 **** } sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx); tot_len += strlen (ext_name + tot_len); ! ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ','; tot_len++; } --- 1426,1432 ---- } sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx); tot_len += strlen (ext_name + tot_len); ! ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ','; tot_len++; } *************** nml_write_obj (st_parameter_dt *dtp, nam *** 1437,1447 **** obj_loop: nml_carry = 1; ! for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++) { obj->ls[dim_i].idx += nml_carry ; nml_carry = 0; ! if (obj->ls[dim_i].idx > (ssize_t)obj->dim[dim_i].ubound) { obj->ls[dim_i].idx = obj->dim[dim_i].lbound; nml_carry = 1; --- 1480,1490 ---- obj_loop: nml_carry = 1; ! for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++) { obj->ls[dim_i].idx += nml_carry ; nml_carry = 0; ! if (obj->ls[dim_i].idx > (index_type) obj->dim[dim_i].ubound) { obj->ls[dim_i].idx = obj->dim[dim_i].lbound; nml_carry = 1; diff -Nrcpad gcc-4.4.0/libgfortran/io/write_float.def gcc-4.4.1/libgfortran/io/write_float.def *** gcc-4.4.0/libgfortran/io/write_float.def Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/io/write_float.def Wed May 27 01:21:22 2009 *************** output_float_FMT_G_ ## x (st_parameter_d *** 603,609 **** int d = f->u.real.d;\ int w = f->u.real.w;\ fnode *newf;\ ! GFC_REAL_ ## x exp_d;\ int low, high, mid;\ int ubound, lbound;\ char *p;\ --- 603,609 ---- int d = f->u.real.d;\ int w = f->u.real.w;\ fnode *newf;\ ! GFC_REAL_ ## x rexp_d;\ int low, high, mid;\ int ubound, lbound;\ char *p;\ *************** output_float_FMT_G_ ## x (st_parameter_d *** 612,619 **** save_scale_factor = dtp->u.p.scale_factor;\ newf = (fnode *) get_mem (sizeof (fnode));\ \ ! exp_d = calculate_exp_ ## x (d);\ ! if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||\ ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\ { \ newf->format = FMT_E;\ --- 612,619 ---- save_scale_factor = dtp->u.p.scale_factor;\ newf = (fnode *) get_mem (sizeof (fnode));\ \ ! rexp_d = calculate_exp_ ## x (-d);\ ! if ((m > 0.0 && m < 0.1 - 0.05 * rexp_d) || (rexp_d * (m + 0.5) >= 1.0) ||\ ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\ { \ newf->format = FMT_E;\ *************** output_float_FMT_G_ ## x (st_parameter_d *** 635,642 **** GFC_REAL_ ## x temp;\ mid = (low + high) / 2;\ \ ! temp = (calculate_exp_ ## x (mid) - \ ! 5 * calculate_exp_ ## x (mid - d - 1)) / 10;\ \ if (m < temp)\ { \ --- 635,641 ---- GFC_REAL_ ## x temp;\ mid = (low + high) / 2;\ \ ! temp = (calculate_exp_ ## x (mid - 1) * (1 - 0.5 * rexp_d));\ \ if (m < temp)\ { \ diff -Nrcpad gcc-4.4.0/libgfortran/libgfortran.h gcc-4.4.1/libgfortran/libgfortran.h *** gcc-4.4.0/libgfortran/libgfortran.h Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/libgfortran.h Wed May 27 01:21:22 2009 *************** internal_proto(show_backtrace); *** 631,641 **** extern void sys_exit (int) __attribute__ ((noreturn)); internal_proto(sys_exit); ! extern const char *gfc_itoa (GFC_INTEGER_LARGEST, char *, size_t); ! internal_proto(gfc_itoa); ! ! extern const char *xtoa (GFC_UINTEGER_LARGEST, char *, size_t); ! internal_proto(xtoa); extern void os_error (const char *) __attribute__ ((noreturn)); iexport_proto(os_error); --- 631,638 ---- extern void sys_exit (int) __attribute__ ((noreturn)); internal_proto(sys_exit); ! extern const char *gfc_xtoa (GFC_UINTEGER_LARGEST, char *, size_t); ! internal_proto(gfc_xtoa); extern void os_error (const char *) __attribute__ ((noreturn)); iexport_proto(os_error); diff -Nrcpad gcc-4.4.0/libgfortran/runtime/backtrace.c gcc-4.4.1/libgfortran/runtime/backtrace.c *** gcc-4.4.0/libgfortran/runtime/backtrace.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/runtime/backtrace.c Wed May 27 01:21:22 2009 *************** show_backtrace (void) *** 147,153 **** /* Write the list of addresses in hexadecimal format. */ for (i = 0; i < depth; i++) ! addr[i] = xtoa ((GFC_UINTEGER_LARGEST) (intptr_t) trace[i], addr_buf[i], sizeof (addr_buf[i])); /* Don't output an error message if something goes wrong, we'll simply --- 147,153 ---- /* Write the list of addresses in hexadecimal format. */ for (i = 0; i < depth; i++) ! addr[i] = gfc_xtoa ((GFC_UINTEGER_LARGEST) (intptr_t) trace[i], addr_buf[i], sizeof (addr_buf[i])); /* Don't output an error message if something goes wrong, we'll simply diff -Nrcpad gcc-4.4.0/libgfortran/runtime/error.c gcc-4.4.1/libgfortran/runtime/error.c *** gcc-4.4.0/libgfortran/runtime/error.c Thu Apr 9 23:23:07 2009 --- gcc-4.4.1/libgfortran/runtime/error.c Wed May 27 01:21:22 2009 *************** sys_exit (int code) *** 112,158 **** * Other error returns are reserved for the STOP statement with a numeric code. */ ! /* gfc_itoa()-- Integer to decimal conversion. */ ! ! const char * ! gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len) ! { ! int negative; ! char *p; ! GFC_UINTEGER_LARGEST t; ! ! assert (len >= GFC_ITOA_BUF_SIZE); ! ! if (n == 0) ! return "0"; ! ! negative = 0; ! t = n; ! if (n < 0) ! { ! negative = 1; ! t = -n; /*must use unsigned to protect from overflow*/ ! } ! ! p = buffer + GFC_ITOA_BUF_SIZE - 1; ! *p = '\0'; ! ! while (t != 0) ! { ! *--p = '0' + (t % 10); ! t /= 10; ! } ! ! if (negative) ! *--p = '-'; ! return p; ! } ! ! ! /* xtoa()-- Integer to hexadecimal conversion. */ const char * ! xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) { int digit; char *p; --- 112,121 ---- * Other error returns are reserved for the STOP statement with a numeric code. */ ! /* gfc_xtoa()-- Integer to hexadecimal conversion. */ const char * ! gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len) { int digit; char *p;