X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=libgfortran%2Fio%2Ftransfer.c;h=e8bf06462262e089c29a074efba555198aae6f05;hp=c5d26a5973f34b46910f29bffb0053b481ffea35;hb=26ba582ebacb59ef6a9a18083c53f05df1ec40e5;hpb=4cc5bde53ae4fc2a8fd82663ec5fde84ba514360 diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index c5d26a5973f..e8bf0646226 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -1,10 +1,10 @@ -/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 +/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught Namelist transfer functions contributed by Paul Thomas F2003 I/O support contributed by Jerry DeLisle -This file is part of the GNU Fortran 95 runtime library (libgfortran). +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 @@ -175,9 +175,49 @@ current_mode (st_parameter_dt *dtp) } -/* Mid level data transfer statements. These subroutines do reading - and writing in the style of salloc_r()/salloc_w() within the - current record. */ +/* Mid level data transfer statements. */ + +/* Read sequential file - internal unit */ + +static char * +read_sf_internal (st_parameter_dt *dtp, int * length) +{ + static char *empty_string[0]; + char *base; + int lorig; + + /* Zero size array gives internal unit len of 0. Nothing to read. */ + if (dtp->internal_unit_len == 0 + && dtp->u.p.current_unit->pad_status == PAD_NO) + hit_eof (dtp); + + /* 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; + } + + lorig = *length; + base = mem_alloc_r (dtp->u.p.current_unit->s, length); + + if (unlikely (lorig > *length)) + { + hit_eof (dtp); + return NULL; + } + + 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; + +} /* When reading sequential formatted records we have a problem. We don't know how long the line is until we read the trailing newline, @@ -191,12 +231,14 @@ current_mode (st_parameter_dt *dtp) For larger allocations, we are forced to allocate memory on the heap. Hopefully this won't happen very often. */ -char * +/* Read sequential file - external unit */ + +static char * read_sf (st_parameter_dt *dtp, int * length) { static char *empty_string[0]; char *base, *p, q; - int n, lorig, memread, seen_comma; + int n, lorig, seen_comma; /* If we have seen an eor previously, return a length of 0. The caller is responsible for correctly padding the input field. */ @@ -208,19 +250,6 @@ read_sf (st_parameter_dt *dtp, int * length) 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. */ @@ -307,11 +336,14 @@ read_sf (st_parameter_dt *dtp, int * length) else dtp->u.p.at_eof = 1; } - else - { - hit_eof (dtp); - return NULL; - } + else if (dtp->u.p.advance_status == ADVANCE_NO + || dtp->u.p.current_unit->pad_status == PAD_NO + || dtp->u.p.current_unit->bytes_left + == dtp->u.p.current_unit->recl) + { + hit_eof (dtp); + return NULL; + } } done: @@ -352,7 +384,8 @@ read_block_form (st_parameter_dt *dtp, int * nbytes) dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; else { - if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO)) + if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO) + && !is_internal_unit (dtp)) { /* Not enough data left. */ generate_error (&dtp->common, LIBERROR_EOR, NULL); @@ -360,9 +393,10 @@ read_block_form (st_parameter_dt *dtp, int * nbytes) } } - if (unlikely (dtp->u.p.current_unit->bytes_left == 0)) + if (unlikely (dtp->u.p.current_unit->bytes_left == 0 + && !is_internal_unit(dtp))) { - hit_eof (dtp); + hit_eof (dtp); return NULL; } @@ -374,7 +408,11 @@ read_block_form (st_parameter_dt *dtp, int * nbytes) (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL || dtp->u.p.current_unit->flags.access == ACCESS_STREAM)) { - source = read_sf (dtp, nbytes); + if (is_internal_unit (dtp)) + source = read_sf_internal (dtp, nbytes); + else + source = read_sf (dtp, nbytes); + dtp->u.p.current_unit->strm_pos += (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor); return source; @@ -602,16 +640,19 @@ write_block (st_parameter_dt *dtp, int length) if (is_internal_unit (dtp)) { - dest = mem_alloc_w (dtp->u.p.current_unit->s, &length); + if (dtp->common.unit) /* char4 internal unit. */ + dest = mem_alloc_w4 (dtp->u.p.current_unit->s, &length); + else + dest = mem_alloc_w (dtp->u.p.current_unit->s, &length); - if (dest == NULL) - { - generate_error (&dtp->common, LIBERROR_END, NULL); - return NULL; - } + if (dest == NULL) + { + generate_error (&dtp->common, LIBERROR_END, NULL); + return NULL; + } - if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE)) - generate_error (&dtp->common, LIBERROR_END, NULL); + if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE)) + generate_error (&dtp->common, LIBERROR_END, NULL); } else { @@ -1005,7 +1046,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind case FMT_B: if (n == 0) goto need_read_data; - if (compile_options.allow_std < GFC_STD_GNU + if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; read_radix (dtp, f, p, kind, 2); @@ -1014,7 +1055,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind case FMT_O: if (n == 0) goto need_read_data; - if (compile_options.allow_std < GFC_STD_GNU + if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; read_radix (dtp, f, p, kind, 8); @@ -1023,7 +1064,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind case FMT_Z: if (n == 0) goto need_read_data; - if (compile_options.allow_std < GFC_STD_GNU + if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; read_radix (dtp, f, p, kind, 16); @@ -1406,7 +1447,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin case FMT_B: if (n == 0) goto need_data; - if (compile_options.allow_std < GFC_STD_GNU + if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; write_b (dtp, f, p, kind); @@ -1415,7 +1456,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin case FMT_O: if (n == 0) goto need_data; - if (compile_options.allow_std < GFC_STD_GNU + if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; write_o (dtp, f, p, kind); @@ -1424,7 +1465,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin case FMT_Z: if (n == 0) goto need_data; - if (compile_options.allow_std < GFC_STD_GNU + if (!(compile_options.allow_std & GFC_STD_GNU) && require_type (dtp, BT_INTEGER, type, f)) return; write_z (dtp, f, p, kind); @@ -2095,49 +2136,49 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) dtp->u.p.current_unit = get_unit (dtp, 1); if (dtp->u.p.current_unit->s == NULL) - { /* Open the unit with some default flags. */ - st_parameter_open opp; - unit_convert conv; + { /* Open the unit with some default flags. */ + st_parameter_open opp; + unit_convert conv; - if (dtp->common.unit < 0) - { - close_unit (dtp->u.p.current_unit); - dtp->u.p.current_unit = NULL; - generate_error (&dtp->common, LIBERROR_BAD_OPTION, - "Bad unit number in statement"); - return; - } - memset (&u_flags, '\0', sizeof (u_flags)); - u_flags.access = ACCESS_SEQUENTIAL; - u_flags.action = ACTION_READWRITE; - - /* Is it unformatted? */ - if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT - | IOPARM_DT_IONML_SET))) - u_flags.form = FORM_UNFORMATTED; - else - u_flags.form = FORM_UNSPECIFIED; - - u_flags.delim = DELIM_UNSPECIFIED; - u_flags.blank = BLANK_UNSPECIFIED; - u_flags.pad = PAD_UNSPECIFIED; - u_flags.decimal = DECIMAL_UNSPECIFIED; - u_flags.encoding = ENCODING_UNSPECIFIED; - u_flags.async = ASYNC_UNSPECIFIED; - u_flags.round = ROUND_UNSPECIFIED; - u_flags.sign = SIGN_UNSPECIFIED; - - u_flags.status = STATUS_UNKNOWN; - - conv = get_unformatted_convert (dtp->common.unit); - - if (conv == GFC_CONVERT_NONE) - conv = compile_options.convert; - - /* We use big_endian, which is 0 on little-endian machines - and 1 on big-endian machines. */ - switch (conv) - { + if (dtp->common.unit < 0) + { + close_unit (dtp->u.p.current_unit); + dtp->u.p.current_unit = NULL; + generate_error (&dtp->common, LIBERROR_BAD_OPTION, + "Bad unit number in statement"); + return; + } + memset (&u_flags, '\0', sizeof (u_flags)); + u_flags.access = ACCESS_SEQUENTIAL; + u_flags.action = ACTION_READWRITE; + + /* Is it unformatted? */ + if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT + | IOPARM_DT_IONML_SET))) + u_flags.form = FORM_UNFORMATTED; + else + u_flags.form = FORM_UNSPECIFIED; + + u_flags.delim = DELIM_UNSPECIFIED; + u_flags.blank = BLANK_UNSPECIFIED; + u_flags.pad = PAD_UNSPECIFIED; + u_flags.decimal = DECIMAL_UNSPECIFIED; + u_flags.encoding = ENCODING_UNSPECIFIED; + u_flags.async = ASYNC_UNSPECIFIED; + u_flags.round = ROUND_UNSPECIFIED; + u_flags.sign = SIGN_UNSPECIFIED; + + u_flags.status = STATUS_UNKNOWN; + + conv = get_unformatted_convert (dtp->common.unit); + + if (conv == GFC_CONVERT_NONE) + conv = compile_options.convert; + + /* We use big_endian, which is 0 on little-endian machines + and 1 on big-endian machines. */ + switch (conv) + { case GFC_CONVERT_NATIVE: case GFC_CONVERT_SWAP: break; @@ -2153,18 +2194,18 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) default: internal_error (&opp.common, "Illegal value for CONVERT"); break; - } + } - u_flags.convert = conv; + u_flags.convert = conv; - opp.common = dtp->common; - opp.common.flags &= IOPARM_COMMON_MASK; - dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags); - dtp->common.flags &= ~IOPARM_COMMON_MASK; - dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK); - if (dtp->u.p.current_unit == NULL) - return; - } + opp.common = dtp->common; + opp.common.flags &= IOPARM_COMMON_MASK; + dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags); + dtp->common.flags &= ~IOPARM_COMMON_MASK; + dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK); + if (dtp->u.p.current_unit == NULL) + return; + } /* Check the action. */ @@ -2230,15 +2271,25 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) return; } - if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL - && (cf & IOPARM_DT_HAS_REC) != 0) + if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) { - generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, - "Record number not allowed for sequential access " - "data transfer"); - return; - } + if ((cf & IOPARM_DT_HAS_REC) != 0) + { + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, + "Record number not allowed for sequential access " + "data transfer"); + return; + } + if (dtp->u.p.current_unit->endfile == AFTER_ENDFILE) + { + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, + "Sequential READ or WRITE not allowed after " + "EOF marker, possibly use REWIND or BACKSPACE"); + return; + } + + } /* Process the ADVANCE option. */ dtp->u.p.advance_status @@ -2731,7 +2782,7 @@ min_off (gfc_offset a, gfc_offset b) /* Space to the next record for read mode. */ static void -next_record_r (st_parameter_dt *dtp) +next_record_r (st_parameter_dt *dtp, int done) { gfc_offset record; int bytes_left; @@ -2758,10 +2809,9 @@ next_record_r (st_parameter_dt *dtp) 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) + if (dtp->u.p.sf_seen_eor) { dtp->u.p.sf_seen_eor = 0; - dtp->u.p.at_eof = 0; break; } @@ -2773,6 +2823,8 @@ next_record_r (st_parameter_dt *dtp) record = next_array_record (dtp, dtp->u.p.current_unit->ls, &finished); + if (!done && finished) + hit_eof (dtp); /* Now seek to this record. */ record = record * dtp->u.p.current_unit->recl; @@ -2810,6 +2862,14 @@ next_record_r (st_parameter_dt *dtp) { if (errno != 0) generate_error (&dtp->common, LIBERROR_OS, NULL); + else + { + if (is_stream_io (dtp) + || dtp->u.p.current_unit->pad_status == PAD_NO + || dtp->u.p.current_unit->bytes_left + == dtp->u.p.current_unit->recl) + hit_eof (dtp); + } break; } @@ -3149,7 +3209,7 @@ next_record (st_parameter_dt *dtp, int done) dtp->u.p.current_unit->read_bad = 0; if (dtp->u.p.mode == READING) - next_record_r (dtp); + next_record_r (dtp, done); else next_record_w (dtp, done);