diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f517550c863..65911dc7302 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2016-10-26 Fritz Reese + + * frontend-passes.c (gfc_code_walker): Add SHARE and CARRIAGECONTROL. + * io.c (gfc_free_open, gfc_resolve_open, gfc_match_open): Ditto. + * gfortran.h (gfc_open): Add SHARE, CARRIAGECONTROL, and READONLY. + * io.c (io_tag, match_open_element): Ditto. + * ioparm.def: Ditto. + * trans-io.c (gfc_trans_open): Ditto. + * io.c (match_dec_etag, match_dec_ftag): New functions. + * gfortran.texi: Document. + 2016-10-25 Fritz Reese * gfortran.texi: Document. diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 53b3c546f88..e61673fc6e4 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -3540,6 +3540,8 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, WALK_SUBEXPR (co->ext.open->asynchronous); WALK_SUBEXPR (co->ext.open->id); WALK_SUBEXPR (co->ext.open->newunit); + WALK_SUBEXPR (co->ext.open->share); + WALK_SUBEXPR (co->ext.open->cc); break; case EXEC_CLOSE: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 37423b7524a..ea4437c5d83 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2284,7 +2284,9 @@ typedef struct { gfc_expr *unit, *file, *status, *access, *form, *recl, *blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert, - *decimal, *encoding, *round, *sign, *asynchronous, *id, *newunit; + *decimal, *encoding, *round, *sign, *asynchronous, *id, *newunit, + *share, *cc; + char readonly; gfc_st_label *err; } gfc_open; @@ -2313,7 +2315,7 @@ typedef struct *unformatted, *recl, *nextrec, *blank, *position, *action, *read, *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert, *strm_pos, *asynchronous, *decimal, *encoding, *pending, *round, *sign, *size, *id, - *iqstream; + *iqstream, *share, *cc; gfc_st_label *err; diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 0278bd6eef7..e65c2decad2 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1470,6 +1470,7 @@ compatibility extensions along with those enabled by @option{-std=legacy}. * %LOC as an rvalue:: * .XOR. operator:: * Bitwise logical operators:: +* Extended I/O specifiers:: @end menu @node Old-style kind specifications @@ -2605,6 +2606,95 @@ Here is the mapping of logical operator to bitwise intrinsic used with @item @code{.EQV.} @tab @code{@ref{NOT}(@ref{IEOR})} @tab complement of exclusive or @end multitable +@node Extended I/O specifiers +@subsection Extended I/O specifiers +@cindex @code{CARRIAGECONTROL} +@cindex @code{READONLY} +@cindex @code{SHARE} +@cindex @code{SHARED} +@cindex @code{NOSHARED} +@cindex I/O specifiers + +GNU Fortran supports the additional legacy I/O specifiers +@code{CARRIAGECONTROL}, @code{READONLY}, and @code{SHARE} with the +compile flag @option{-fdec}, for compatibility. + +@table @code +@item CARRIAGECONTROL +The @code{CARRIAGECONTROL} specifier allows a user to control line +termination settings between output records for an I/O unit. The specifier has +no meaning for readonly files. When @code{CARRAIGECONTROL} is specified upon +opening a unit for formatted writing, the exact @code{CARRIAGECONTROL} setting +determines what characters to write between output records. The syntax is: + +@smallexample +OPEN(..., CARRIAGECONTROL=cc) +@end smallexample + +Where @emph{cc} is a character expression that evaluates to one of the +following values: + +@multitable @columnfractions .2 .8 +@item @code{'LIST'} @tab One line feed between records (default) +@item @code{'FORTRAN'} @tab Legacy interpretation of the first character (see below) +@item @code{'NONE'} @tab No separator between records +@end multitable + +With @code{CARRIAGECONTROL='FORTRAN'}, when a record is written, the first +character of the input record is not written, and instead determines the output +record separator as follows: + +@multitable @columnfractions .3 .3 .4 +@headitem Leading character @tab Meaning @tab Output separating character(s) +@item @code{'+'} @tab Overprinting @tab Carriage return only +@item @code{'-'} @tab New line @tab Line feed and carriage return +@item @code{'0'} @tab Skip line @tab Two line feeds and carriage return +@item @code{'1'} @tab New page @tab Form feed and carriage return +@item @code{'$'} @tab Prompting @tab Line feed (no carriage return) +@item @code{CHAR(0)} @tab Overprinting (no advance) @tab None +@end multitable + +@item READONLY +The @code{READONLY} specifier may be given upon opening a unit, and is +equivalent to specifying @code{ACTION='READ'}, except that the file may not be +deleted on close (i.e. @code{CLOSE} with @code{STATUS="DELETE"}). The syntax +is: + +@smallexample +@code{OPEN(..., READONLY)} +@end smallexample + +@item SHARE +The @code{SHARE} specifier allows system-level locking on a unit upon opening +it for controlled access from multiple processes/threads. The @code{SHARE} +specifier has several forms: + +@smallexample +OPEN(..., SHARE=sh) +OPEN(..., SHARED) +OPEN(..., NOSHARED) +@end smallexample + +Where @emph{sh} in the first form is a character expression that evaluates to +a value as seen in the table below. The latter two forms are aliases +for particular values of @emph{sh}: + +@multitable @columnfractions .3 .3 .4 +@headitem Explicit form @tab Short form @tab Meaning +@item @code{SHARE='DENYRW'} @tab @code{NOSHARED} @tab Exclusive (write) lock +@item @code{SHARE='DENYNONE'} @tab @code{SHARED} @tab Shared (read) lock +@end multitable + +In general only one process may hold an exclusive (write) lock for a given file +at a time, whereas many processes may hold shared (read) locks for the same +file. + +The behavior of locking may vary with your operating system. On POSIX systems, +locking is implemented with @code{fcntl}. Consult your corresponding operating +system's manual pages for further details. Locking via @code{SHARE=} is not +supported on other systems. + +@end table @node Extensions not implemented in GNU Fortran @section Extensions not implemented in GNU Fortran @@ -2629,7 +2719,7 @@ code that uses them running with the GNU Fortran compiler. * Variable FORMAT expressions:: @c * Q edit descriptor:: @c * TYPE and ACCEPT I/O Statements:: -@c * CARRIAGECONTROL, DEFAULTFILE, DISPOSE and RECORDTYPE I/O specifiers:: +@c * DEFAULTFILE, DISPOSE and RECORDTYPE I/O specifiers:: @c * Omitted arguments in procedure call:: * Alternate complex function syntax:: * Volatile COMMON blocks:: diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 7c48c491eeb..dce0f7cd970 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -38,6 +38,15 @@ typedef struct io_tag; static const io_tag + tag_readonly = {"READONLY", " readonly", NULL, BT_UNKNOWN }, + tag_shared = {"SHARE", " shared", NULL, BT_UNKNOWN }, + tag_noshared = {"SHARE", " noshared", NULL, BT_UNKNOWN }, + tag_e_share = {"SHARE", " share =", " %e", BT_CHARACTER }, + tag_v_share = {"SHARE", " share =", " %v", BT_CHARACTER }, + tag_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %e", + BT_CHARACTER }, + tag_v_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %v", + BT_CHARACTER }, tag_file = {"FILE", " file =", " %e", BT_CHARACTER }, tag_status = {"STATUS", " status =", " %e", BT_CHARACTER}, tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER}, @@ -1495,6 +1504,97 @@ match_ltag (const io_tag *tag, gfc_st_label ** label) } +/* Match a tag using match_etag, but only if -fdec is enabled. */ +static match +match_dec_etag (const io_tag *tag, gfc_expr **e) +{ + match m = match_etag (tag, e); + if (flag_dec && m != MATCH_NO) + return m; + else if (m != MATCH_NO) + { + gfc_error ("%s is a DEC extension at %C, re-compile with " + "-fdec to enable", tag->name); + return MATCH_ERROR; + } + return m; +} + + +/* Match a tag using match_vtag, but only if -fdec is enabled. */ +static match +match_dec_vtag (const io_tag *tag, gfc_expr **e) +{ + match m = match_vtag(tag, e); + if (flag_dec && m != MATCH_NO) + return m; + else if (m != MATCH_NO) + { + gfc_error ("%s is a DEC extension at %C, re-compile with " + "-fdec to enable", tag->name); + return MATCH_ERROR; + } + return m; +} + + +/* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */ + +static match +match_dec_ftag (const io_tag *tag, gfc_open *o) +{ + match m; + + m = gfc_match (tag->spec); + if (m != MATCH_YES) + return m; + + if (!flag_dec) + { + gfc_error ("%s is a DEC extension at %C, re-compile with " + "-fdec to enable", tag->name); + return MATCH_ERROR; + } + + /* Just set the READONLY flag, which we use at runtime to avoid delete on + close. */ + if (tag == &tag_readonly) + { + o->readonly |= 1; + return MATCH_YES; + } + + /* Interpret SHARED as SHARE='DENYNONE' (read lock). */ + else if (tag == &tag_shared) + { + if (o->share != NULL) + { + gfc_error ("Duplicate %s specification at %C", tag->name); + return MATCH_ERROR; + } + o->share = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, "denynone", 8); + return MATCH_YES; + } + + /* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */ + else if (tag == &tag_noshared) + { + if (o->share != NULL) + { + gfc_error ("Duplicate %s specification at %C", tag->name); + return MATCH_ERROR; + } + o->share = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, "denyrw", 6); + return MATCH_YES; + } + + /* We handle all DEC tags above. */ + gcc_unreachable (); +} + + /* Resolution of the FORMAT tag, to be called from resolve_tag. */ static bool @@ -1743,6 +1843,23 @@ match_open_element (gfc_open *open) if (m != MATCH_NO) return m; + /* The following are extensions enabled with -fdec. */ + m = match_dec_etag (&tag_e_share, &open->share); + if (m != MATCH_NO) + return m; + m = match_dec_etag (&tag_cc, &open->cc); + if (m != MATCH_NO) + return m; + m = match_dec_ftag (&tag_readonly, open); + if (m != MATCH_NO) + return m; + m = match_dec_ftag (&tag_shared, open); + if (m != MATCH_NO) + return m; + m = match_dec_ftag (&tag_noshared, open); + if (m != MATCH_NO) + return m; + return MATCH_NO; } @@ -1775,6 +1892,8 @@ gfc_free_open (gfc_open *open) gfc_free_expr (open->convert); gfc_free_expr (open->asynchronous); gfc_free_expr (open->newunit); + gfc_free_expr (open->share); + gfc_free_expr (open->cc); free (open); } @@ -1805,6 +1924,8 @@ gfc_resolve_open (gfc_open *open) RESOLVE_TAG (&tag_e_sign, open->sign); RESOLVE_TAG (&tag_convert, open->convert); RESOLVE_TAG (&tag_newunit, open->newunit); + RESOLVE_TAG (&tag_e_share, open->share); + RESOLVE_TAG (&tag_cc, open->cc); if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET)) return false; @@ -2014,15 +2135,29 @@ gfc_match_open (void) /* Checks on the ACTION specifier. */ if (open->action && open->action->expr_type == EXPR_CONSTANT) { + gfc_char_t *str = open->action->value.character.string; static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; if (!is_char_type ("ACTION", open->action)) goto cleanup; if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, - open->action->value.character.string, - "OPEN", warn)) + str, "OPEN", warn)) goto cleanup; + + /* With READONLY, only allow ACTION='READ'. */ + if (open->readonly && (gfc_wide_strlen (str) != 4 + || gfc_wide_strncasecmp (str, "READ", 4) != 0)) + { + gfc_error ("ACTION type conflicts with READONLY specifier at %C"); + goto cleanup; + } + } + /* If we see READONLY and no ACTION, set ACTION='READ'. */ + else if (open->readonly && open->action == NULL) + { + open->action = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, "read", 4); } /* Checks on the ASYNCHRONOUS specifier. */ @@ -2067,6 +2202,22 @@ gfc_match_open (void) } } + /* Checks on the CARRIAGECONTROL specifier. */ + if (open->cc) + { + if (!is_char_type ("CARRIAGECONTROL", open->cc)) + goto cleanup; + + if (open->cc->expr_type == EXPR_CONSTANT) + { + static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL }; + if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL, + open->cc->value.character.string, + "OPEN", warn)) + goto cleanup; + } + } + /* Checks on the DECIMAL specifier. */ if (open->decimal) { @@ -2191,6 +2342,22 @@ gfc_match_open (void) } } + /* Checks on the SHARE specifier. */ + if (open->share) + { + if (!is_char_type ("SHARE", open->share)) + goto cleanup; + + if (open->share->expr_type == EXPR_CONSTANT) + { + static const char *share[] = { "DENYNONE", "DENYRW", NULL }; + if (!compare_to_allowed_values ("SHARE", share, NULL, NULL, + open->share->value.character.string, + "OPEN", warn)) + goto cleanup; + } + } + /* Checks on the SIGN specifier. */ if (open->sign) { @@ -4102,6 +4269,8 @@ gfc_free_inquire (gfc_inquire *inquire) gfc_free_expr (inquire->sign); gfc_free_expr (inquire->size); gfc_free_expr (inquire->round); + gfc_free_expr (inquire->share); + gfc_free_expr (inquire->cc); free (inquire); } @@ -4157,6 +4326,8 @@ match_inquire_element (gfc_inquire *inquire) RETM m = match_vtag (&tag_pending, &inquire->pending); RETM m = match_vtag (&tag_id, &inquire->id); RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream); + RETM m = match_dec_vtag (&tag_v_share, &inquire->share); + RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc); RETM return MATCH_NO; } @@ -4354,6 +4525,8 @@ gfc_resolve_inquire (gfc_inquire *inquire) INQUIRE_RESOLVE_TAG (&tag_size, inquire->size); INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal); INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream); + INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share); + INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc); #undef INQUIRE_RESOLVE_TAG if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET)) diff --git a/gcc/fortran/ioparm.def b/gcc/fortran/ioparm.def index bd628ce26f5..f1bf7330fd0 100644 --- a/gcc/fortran/ioparm.def +++ b/gcc/fortran/ioparm.def @@ -16,6 +16,7 @@ You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see . */ +/* Make sure to keep in sync with libgfortran/io/io.h (st_parameter_*). */ #ifndef IOPARM_common_libreturn_mask #define IOPARM_common_libreturn_mask 3 #define IOPARM_common_libreturn_ok 0 @@ -50,6 +51,9 @@ IOPARM (open, round, 1 << 20, char2) IOPARM (open, sign, 1 << 21, char1) IOPARM (open, asynchronous, 1 << 22, char2) IOPARM (open, newunit, 1 << 23, pint4) +IOPARM (open, readonly, 1 << 24, int4) +IOPARM (open, cc, 1 << 25, char2) +IOPARM (open, share, 1 << 26, char1) IOPARM (close, common, 0, common) IOPARM (close, status, 1 << 7, char1) IOPARM (filepos, common, 0, common) @@ -88,6 +92,8 @@ IOPARM (inquire, pending, 1 << 5, pint4) IOPARM (inquire, size, 1 << 6, pintio) IOPARM (inquire, id, 1 << 7, pint4) IOPARM (inquire, iqstream, 1 << 8, char1) +IOPARM (inquire, share, 1 << 9, char2) +IOPARM (inquire, cc, 1 << 10, char1) IOPARM (wait, common, 0, common) IOPARM (wait, id, 1 << 7, pint4) IOPARM (dt, common, 0, common) diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index a355ee22df9..285e551585c 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1123,6 +1123,14 @@ gfc_trans_open (gfc_code * code) mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit, p->newunit); + if (p->cc) + mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc); + + if (p->share) + mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share); + + mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly); + set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) @@ -1450,6 +1458,13 @@ gfc_trans_inquire (gfc_code * code) mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream, p->iqstream); + if (p->share) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share, + p->share); + + if (p->cc) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc); + if (mask2) mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6e36b43bfe3..d27d57addd5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2016-10-26 Fritz Reese + + * gfortran.dg/dec_io_1.f90: New test. + * gfortran.dg/dec_io_2.f90: New test. + * gfortran.dg/dec_io_3.f90: New test. + * gfortran.dg/dec_io_4.f90: New test. + * gfortran.dg/dec_io_5.f90: New test. + * gfortran.dg/dec_io_6.f90: New test. + 2016-10-25 Jakub Jelinek PR sanitizer/78106 diff --git a/gcc/testsuite/gfortran.dg/dec_io_1.f90 b/gcc/testsuite/gfortran.dg/dec_io_1.f90 new file mode 100644 index 00000000000..c7f59d69a2b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_io_1.f90 @@ -0,0 +1,101 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Run-time tests for values of DEC I/O parameters (doesn't test functionality). +! + +subroutine check_cc (fd, cc) + implicit none + character(*), intent(in) :: cc + integer, intent(in) :: fd + character(20) :: cc_inq + inquire(unit=fd, carriagecontrol=cc_inq) + if (cc_inq .ne. cc) then + print *, '(', fd, ') cc expected ', cc, ' was ', cc_inq + call abort() + endif +endsubroutine + +subroutine check_share (fd, share) + implicit none + character(*), intent(in) :: share + integer, intent(in) :: fd + character(20) :: share_inq + inquire(unit=fd, share=share_inq) + if (share_inq .ne. share) then + print *, '(', fd, ') share expected ', share, ' was ', share_inq + call abort() + endif +endsubroutine + +subroutine check_action (fd, acc) + implicit none + character(*), intent(in) :: acc + integer, intent(in) :: fd + character(20) acc_inq + inquire(unit=fd, action=acc_inq) + if (acc_inq .ne. acc) then + print *, '(', fd, ') access expected ', acc, ' was ', acc_inq + call abort() + endif +endsubroutine + +implicit none + +integer, parameter :: fd=3 +character(*), parameter :: fname = 'dec_io_1.txt' + +!!!! + +open(unit=fd, file=fname, action='WRITE') +call check_cc(fd, 'LIST') +call check_share(fd, 'NODENY') +write (fd,*) 'test' +close(unit=fd) + +!!!! READONLY + +open (unit=fd, file=fname, readonly) +call check_action(fd, 'READ') +close (unit=fd) + +!!!! SHARED / SHARE='DENYNONE' + +open (unit=fd, file=fname, action='read', shared) +call check_share(fd, 'DENYNONE') +close (unit=fd) + +open (unit=fd, file=fname, action='read', share='DENYNONE') +call check_share(fd, 'DENYNONE') +close (unit=fd) + +!!!! NOSHARED / SHARE='DENYRW' + +open (unit=fd, file=fname, action='write', noshared) +call check_share(fd, 'DENYRW') +close (unit=fd) + +open (unit=fd, file=fname, action='write', share='DENYRW') +call check_share(fd, 'DENYRW') +close (unit=fd) + +!!!! CC=FORTRAN + +open(unit=fd, file=fname, action ='WRITE', carriagecontrol='FORTRAN') +call check_cc(fd, 'FORTRAN') +close(unit=fd) + +!!!! CC=LIST + +open(unit=fd, file=fname, action ='WRITE', carriagecontrol='LIST') +call check_cc(fd, 'LIST') +close(unit=fd) + +!!!! CC=NONE + +open(unit=fd, file=fname, action ='WRITE', carriagecontrol='NONE') +call check_cc(fd, 'NONE') +close(unit=fd, status='delete') ! cleanup temp file + + +end diff --git a/gcc/testsuite/gfortran.dg/dec_io_2.f90 b/gcc/testsuite/gfortran.dg/dec_io_2.f90 new file mode 100644 index 00000000000..9adc4f4003f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_io_2.f90 @@ -0,0 +1,104 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Run-time tests for various carriagecontrol parameters with DEC I/O. +! Ensures the output is as defined. +! + +subroutine write_lines(fd) + implicit none + integer, intent(in) :: fd + write(fd, '(A)') "+ first" + write(fd, '(A)') "-second line" + write(fd, '(A)') "0now you know" + write(fd, '(A)') "1this is the fourth line" + write(fd, '(A)') "$finally we have a new challenger for the final line" + write(fd, '(A)') CHAR(0)//"this is the end" + write(fd, '(A)') " this is a plain old line" +endsubroutine + +subroutine check_cc (cc, fname, expected) + implicit none + ! carraigecontrol type, file name to write to + character(*), intent(in) :: cc, fname + ! expected output + character(*), intent(in) :: expected + + ! read buffer, line number, unit, status + character(len=:), allocatable :: buf + integer :: i, fd, siz + fd = 3 + + ! write lines using carriagecontrol setting + open(unit=fd, file=fname, action='write', carriagecontrol=cc) + call write_lines(fd) + close(unit=fd) + + open(unit=fd, file=fname, action='readwrite', & + form='unformatted', access='stream') + call fseek(fd, 0, 0) + inquire(file=fname, size=siz) + allocate(character(len=siz) :: buf) + read(unit=fd, pos=1) buf + if (buf .ne. expected) then + print *, '=================> ',cc,' <=================' + print *, '***** actual *****' + print *, buf + print *, '***** expected *****' + print *, expected + deallocate(buf) + close(unit=fd) + call abort() + else + deallocate(buf) + close(unit=fd, status='delete') + endif +endsubroutine + +implicit none + +character(*), parameter :: fname = 'dec_io_2.txt' + +!! In NONE mode, there are no line breaks between records. +character(*), parameter :: output_ccnone = & + "+ first"//& + "-second line"//& + "0now you know"//& + "1this is the fourth line"//& + "$finally we have a new challenger for the final line"//& + CHAR(0)//"this is the end"//& + " this is a plain old line" + +!! In LIST mode, each record is terminated with a newline. +character(*), parameter :: output_cclist = & + "+ first"//CHAR(10)//& + "-second line"//CHAR(10)//& + "0now you know"//CHAR(10)//& + "1this is the fourth line"//CHAR(10)//& + "$finally we have a new challenger for the final line"//CHAR(10)//& + CHAR(0)//"this is the end"//CHAR(10)//& + " this is a plain old line"//CHAR(10) + +!! In FORTRAN mode, the default record break is CR, and the first character +!! implies the start- and end-of-record formatting. +! '+' Overprinting: CR +! '-' One line feed: NL CR +! '0' Two line feeds: NL NL CR +! '1' Next page: FF CR +! '$' Prompting: NL +!'\0' Overprinting with no advance: +! Other: defaults to Overprinting CR +character(*), parameter :: output_ccfort = ""//& + " first"//CHAR(13)//& + CHAR(10)//"second line"//CHAR(13)//& + CHAR(10)//CHAR(10)//"now you know"//CHAR(13)//& + CHAR(12)//"this is the fourth line"//CHAR(13)//& + CHAR(10)//"finally we have a new challenger for the final line"//& + "this is the end"//& + CHAR(10)//"this is a plain old line"//CHAR(13) + +call check_cc('none', fname, output_ccnone) +call check_cc('list', fname, output_cclist) +call check_cc('fortran', fname, output_ccfort) + +end diff --git a/gcc/testsuite/gfortran.dg/dec_io_3.f90 b/gcc/testsuite/gfortran.dg/dec_io_3.f90 new file mode 100644 index 00000000000..d37961c735a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_io_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "" } +! +! Test compile-time errors for DEC I/O intrinsics without -fdec. +! + +integer :: fd +open (unit=fd, carriagecontrol='cc') ! { dg-error "is a DEC extension" } +open (unit=fd, share='cc') ! { dg-error "is a DEC extension" } +open (unit=fd, shared) ! { dg-error "is a DEC extension" } +open (unit=fd, noshared) ! { dg-error "is a DEC extension" } +open (unit=fd, readonly) ! { dg-error "is a DEC extension" } +close (unit=fd, status='delete') + +end diff --git a/gcc/testsuite/gfortran.dg/dec_io_4.f90 b/gcc/testsuite/gfortran.dg/dec_io_4.f90 new file mode 100644 index 00000000000..9b8fbc9f767 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_io_4.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! +! Test compile-time errors for DEC I/O intrinsics with -fdec. +! + +integer :: fd +open (unit=fd, readonly, action='read') ! these are okay +open (unit=fd, action='read', readonly) +open (unit=fd, readonly, action='write') ! { dg-error "ACTION type conflicts" } +open (unit=fd, action='readwrite', readonly) ! { dg-error "ACTION type conflicts" } +open (unit=fd, shared, shared) ! { dg-error "Duplicate SHARE" } +open (unit=fd, noshared, shared) ! { dg-error "Duplicate SHARE" } +open (unit=fd, share='denyrw', share='denynone') ! { dg-error "Duplicate SHARE" } +open (unit=fd, carriagecontrol='fortran', carriagecontrol='none') ! { dg-error "Duplicate CARRIAGECONTROL" } + +end diff --git a/gcc/testsuite/gfortran.dg/dec_io_5.f90 b/gcc/testsuite/gfortran.dg/dec_io_5.f90 new file mode 100644 index 00000000000..9d44c6e7974 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_io_5.f90 @@ -0,0 +1,17 @@ +! { dg-do run "xfail *-*-*" } +! { dg-options "-fdec" } +! +! Test that we get a run-time error for opening a READONLY file with +! ACTION='WRITE'. +! + +implicit none + +integer :: fd = 8 +character(*), parameter :: f = "test.txt" +character(10), volatile :: c +c = 'write' + +open(unit=fd,file=f,action=c,readonly) ! XFAIL "ACTION conflicts with READONLY" + +end diff --git a/gcc/testsuite/gfortran.dg/dec_io_6.f90 b/gcc/testsuite/gfortran.dg/dec_io_6.f90 new file mode 100644 index 00000000000..a0c025680fb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_io_6.f90 @@ -0,0 +1,15 @@ +! { dg-do run "xfail *-*-*" } +! { dg-options "-fdec" } +! +! Test that we get a run-time error for close-on-delete with READONLY. +! + +implicit none + +integer :: fd = 8 +character(*), parameter :: f = "test.txt" + +open(unit=fd,file=f,action='read',readonly) +close(unit=fd,status='delete') ! XFAIL "protected by READONLY" + +end diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 2e3056f2157..107372340ed 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,31 @@ +2016-10-26 Fritz Reese + + * libgfortran.h (IOPARM_OPEN_HAS_READONLY, IOPARM_OPEN_HAS_SHARE, + IOPARM_OPEN_HAS_CC): New for READONLY, SHARE, and CARRIAGECONTROL. + * io/close.c (st_close): Support READONLY. + * io/io.h (st_parameter_open, unit_flags): Support SHARE, + CARRIAGECONTROL, and READONLY. + * io/open.c (st_open): Ditto. + * io/transfer.c (data_transfer_init): Ditto. + * io/io.h (st_parameter_dt): New member 'cc' for CARRIAGECONTROL. + * io/write.c (write_check_cc, write_cc): New functions for + CARRIAGECONTROL. + * io/transfer.c (next_record_cc): Ditto. + * io/file_pos.c (st_endfile): Support SHARE and CARRIAGECONTROL. + * io/io.h (st_parameter_inquire): Ditto. + * io/open.c (edit_modes, new_unit): Ditto. + * io/inquire.c (inquire_via_unit, inquire_via_filename): Ditto. + * io/io.h (unit_share, unit_cc, cc_fortran, IOPARM_INQUIRE_HAS_SHARE, + IOPARM_INQUIRE_HAS_CC): New for SHARE and CARRIAGECONTROL. + * io/open.c (share_opt, cc_opt): Ditto. + * io/read.c (read_x): Support CARRIAGECONTROL. + * io/transfer.c (read_sf, next_record_r, next_record_w): Ditto. + * io/write.c (list_formatted_write_scalar, write_a): Ditto. + * io/unix.h (close_share): New prototype. + * io/unix.c (open_share, close_share): New functions to handle SHARE. + * io/unix.c (open_external): Handle READONLY. Call open_share. + * io/close.c (st_close): Call close_share. + 2016-10-24 Jerry DeLisle PR fortran/77828 diff --git a/libgfortran/io/close.c b/libgfortran/io/close.c index c29c125b10c..8fbfe822170 100644 --- a/libgfortran/io/close.c +++ b/libgfortran/io/close.c @@ -66,6 +66,8 @@ st_close (st_parameter_close *clp) u = find_unit (clp->common.unit); if (u != NULL) { + if (close_share (u) < 0) + generate_error (&clp->common, LIBERROR_OS, "Problem in CLOSE"); if (u->flags.status == STATUS_SCRATCH) { if (status == CLOSE_KEEP) @@ -78,13 +80,19 @@ st_close (st_parameter_close *clp) else { if (status == CLOSE_DELETE) - { + { + if (u->flags.readonly) + generate_warning (&clp->common, "STATUS set to DELETE on CLOSE" + " but file protected by READONLY specifier"); + else + { #if HAVE_UNLINK_OPEN_FILE - remove (u->filename); + remove (u->filename); #else - path = strdup (u->filename); + path = strdup (u->filename); #endif - } + } + } } close_unit (u); diff --git a/libgfortran/io/file_pos.c b/libgfortran/io/file_pos.c index 5720eae655f..6611a8daa63 100644 --- a/libgfortran/io/file_pos.c +++ b/libgfortran/io/file_pos.c @@ -362,6 +362,8 @@ st_endfile (st_parameter_filepos *fpp) u_flags.sign = SIGN_UNSPECIFIED; u_flags.status = STATUS_UNKNOWN; u_flags.convert = GFC_CONVERT_NATIVE; + u_flags.share = SHARE_UNSPECIFIED; + u_flags.cc = CC_UNSPECIFIED; opp.common = fpp->common; opp.common.flags &= IOPARM_COMMON_MASK; diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c index 7e663130e56..7e013e01e8f 100644 --- a/libgfortran/io/inquire.c +++ b/libgfortran/io/inquire.c @@ -428,6 +428,58 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) cf_strcpy (iqp->iqstream, iqp->iqstream_len, p); } + + if ((cf2 & IOPARM_INQUIRE_HAS_SHARE) != 0) + { + if (u == NULL) + p = "UNKNOWN"; + else + switch (u->flags.share) + { + case SHARE_DENYRW: + p = "DENYRW"; + break; + case SHARE_DENYNONE: + p = "DENYNONE"; + break; + case SHARE_UNSPECIFIED: + p = "NODENY"; + break; + default: + internal_error (&iqp->common, + "inquire_via_unit(): Bad share"); + break; + } + + cf_strcpy (iqp->share, iqp->share_len, p); + } + + if ((cf2 & IOPARM_INQUIRE_HAS_CC) != 0) + { + if (u == NULL) + p = "UNKNOWN"; + else + switch (u->flags.cc) + { + case CC_FORTRAN: + p = "FORTRAN"; + break; + case CC_LIST: + p = "LIST"; + break; + case CC_NONE: + p = "NONE"; + break; + case CC_UNSPECIFIED: + p = "UNKNOWN"; + break; + default: + internal_error (&iqp->common, "inquire_via_unit(): Bad cc"); + break; + } + + cf_strcpy (iqp->cc, iqp->cc_len, p); + } } if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) @@ -671,6 +723,12 @@ inquire_via_filename (st_parameter_inquire *iqp) if ((cf2 & IOPARM_INQUIRE_HAS_IQSTREAM) != 0) cf_strcpy (iqp->iqstream, iqp->iqstream_len, "UNKNOWN"); + + if ((cf2 & IOPARM_INQUIRE_HAS_SHARE) != 0) + cf_strcpy (iqp->share, iqp->share_len, "UNKNOWN"); + + if ((cf2 & IOPARM_INQUIRE_HAS_CC) != 0) + cf_strcpy (iqp->cc, iqp->cc_len, "UNKNOWN"); } if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 8c6caefec6e..7a548497af9 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -268,10 +268,36 @@ typedef enum { ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED } unit_async; +typedef enum +{ SHARE_DENYRW, SHARE_DENYNONE, + SHARE_UNSPECIFIED +} +unit_share; + +typedef enum +{ CC_LIST, CC_FORTRAN, CC_NONE, + CC_UNSPECIFIED +} +unit_cc; + +/* End-of-record types for CC_FORTRAN. */ +typedef enum +{ CCF_DEFAULT=0x0, + CCF_OVERPRINT=0x1, + CCF_ONE_LF=0x2, + CCF_TWO_LF=0x4, + CCF_PAGE_FEED=0x8, + CCF_PROMPT=0x10, + CCF_OVERPRINT_NOA=0x20, +} /* 6 bits */ +cc_fortran; + typedef enum { SIGN_S, SIGN_SS, SIGN_SP } unit_sign_s; +/* Make sure to keep st_parameter_* in sync with gcc/fortran/ioparm.def. */ + #define CHARACTER1(name) \ char * name; \ gfc_charlen_type name ## _len @@ -299,6 +325,9 @@ typedef struct CHARACTER1 (sign); CHARACTER2 (asynchronous); GFC_INTEGER_4 *newunit; + GFC_INTEGER_4 readonly; + CHARACTER2 (cc); + CHARACTER1 (share); } st_parameter_open; @@ -352,6 +381,8 @@ st_parameter_filepos; #define IOPARM_INQUIRE_HAS_SIZE (1 << 6) #define IOPARM_INQUIRE_HAS_ID (1 << 7) #define IOPARM_INQUIRE_HAS_IQSTREAM (1 << 8) +#define IOPARM_INQUIRE_HAS_SHARE (1 << 9) +#define IOPARM_INQUIRE_HAS_CC (1 << 10) typedef struct { @@ -386,6 +417,8 @@ typedef struct GFC_IO_INT *size; GFC_INTEGER_4 *id; CHARACTER1 (iqstream); + CHARACTER2 (share); + CHARACTER1 (cc); } st_parameter_inquire; @@ -526,6 +559,21 @@ typedef struct st_parameter_dt GFC_IO_INT not_used; /* Needed for alignment. */ formatted_dtio fdtio_ptr; unformatted_dtio ufdtio_ptr; + /* With CC_FORTRAN, the first character of a record determines the + style of record end (and start) to use. We must mark down the type + when we write first in write_a so we remember the end type later in + next_record_w. */ + struct + { + unsigned type : 6; /* See enum cc_fortran. */ + unsigned len : 2; /* Always 0, 1, or 2. */ + /* The union is updated after start-of-record is written. */ + union + { + char start; /* Output character for start of record. */ + char end; /* Output character for end of record. */ + } u; + } cc; } p; /* This pad size must be equal to the pad_size declared in trans-io.c (gfc_build_io_library_fndecls). The above structure @@ -571,6 +619,9 @@ typedef struct unit_round round; unit_sign sign; unit_async async; + unit_share share; + unit_cc cc; + int readonly; } unit_flags; diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c index 2e7163d33c6..b0f1009deeb 100644 --- a/libgfortran/io/open.c +++ b/libgfortran/io/open.c @@ -52,6 +52,21 @@ static const st_option action_opt[] = { NULL, 0} }; +static const st_option share_opt[] = +{ + { "denyrw", SHARE_DENYRW }, + { "denynone", SHARE_DENYNONE }, + { NULL, 0} +}; + +static const st_option cc_opt[] = +{ + { "list", CC_LIST }, + { "fortran", CC_FORTRAN }, + { "none", CC_NONE }, + { NULL, 0} +}; + static const st_option blank_opt[] = { { "null", BLANK_NULL}, @@ -195,6 +210,14 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags) generate_error (&opp->common, LIBERROR_BAD_OPTION, "Cannot change ACTION parameter in OPEN statement"); + if (flags->share != SHARE_UNSPECIFIED && u->flags.share != flags->share) + generate_error (&opp->common, LIBERROR_BAD_OPTION, + "Cannot change SHARE parameter in OPEN statement"); + + if (flags->cc != CC_UNSPECIFIED && u->flags.cc != flags->cc) + generate_error (&opp->common, LIBERROR_BAD_OPTION, + "Cannot change CARRIAGECONTROL parameter in OPEN statement"); + /* Status must be OLD if present. */ if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD && @@ -330,6 +353,16 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags) if (flags->status == STATUS_UNSPECIFIED) flags->status = STATUS_UNKNOWN; + if (flags->cc == CC_UNSPECIFIED) + flags->cc = flags->form == FORM_UNFORMATTED ? CC_NONE : CC_LIST; + else if (flags->form == FORM_UNFORMATTED && flags->cc != CC_NONE) + { + generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, + "CARRIAGECONTROL parameter conflicts with UNFORMATTED form in " + "OPEN statement"); + goto fail; + } + /* Checks. */ if (flags->delim != DELIM_UNSPECIFIED @@ -695,6 +728,7 @@ st_open (st_parameter_open *opp) library_start (&opp->common); /* Decode options. */ + flags.readonly = !(cf & IOPARM_OPEN_HAS_READONLY) ? 0 : opp->readonly; flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED : find_option (&opp->common, opp->access, opp->access_len, @@ -704,6 +738,14 @@ st_open (st_parameter_open *opp) find_option (&opp->common, opp->action, opp->action_len, action_opt, "Bad ACTION parameter in OPEN statement"); + flags.cc = !(cf & IOPARM_OPEN_HAS_CC) ? CC_UNSPECIFIED : + find_option (&opp->common, opp->cc, opp->cc_len, + cc_opt, "Bad CARRIAGECONTROL parameter in OPEN statement"); + + flags.share = !(cf & IOPARM_OPEN_HAS_SHARE) ? SHARE_UNSPECIFIED : + find_option (&opp->common, opp->share, opp->share_len, + share_opt, "Bad SHARE parameter in OPEN statement"); + flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED : find_option (&opp->common, opp->blank, opp->blank_len, blank_opt, "Bad BLANK parameter in OPEN statement"); @@ -792,6 +834,11 @@ st_open (st_parameter_open *opp) generate_error (&opp->common, LIBERROR_BAD_OPTION, "Cannot use POSITION with direct access files"); + if (flags.readonly + && flags.action != ACTION_UNSPECIFIED && flags.action != ACTION_READ) + generate_error (&opp->common, LIBERROR_BAD_OPTION, + "ACTION conflicts with READONLY in OPEN statement"); + if (flags.access == ACCESS_APPEND) { if (flags.position != POSITION_UNSPECIFIED diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c index d72cdb37e11..23b6f644429 100644 --- a/libgfortran/io/read.c +++ b/libgfortran/io/read.c @@ -1256,7 +1256,8 @@ read_x (st_parameter_dt *dtp, int n) q = fbuf_getc (dtp->u.p.current_unit); if (q == EOF) break; - else if (q == '\n' || q == '\r') + else if (dtp->u.p.current_unit->flags.cc != CC_NONE + && (q == '\n' || q == '\r')) { /* Unexpected end of line. Set the position. */ dtp->u.p.sf_seen_eor = 1; diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index e3f75b67d4e..b8eb5eda20f 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -316,7 +316,8 @@ read_sf (st_parameter_dt *dtp, int * length) q = fbuf_getc (dtp->u.p.current_unit); if (q == EOF) break; - else if (q == '\n' || q == '\r') + else if (dtp->u.p.current_unit->flags.cc != CC_NONE + && (q == '\n' || q == '\r')) { /* Unexpected end of line. Set the position. */ dtp->u.p.sf_seen_eor = 1; @@ -2598,6 +2599,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) dtp->u.p.ionml = ionml; dtp->u.p.mode = read_flag ? READING : WRITING; + dtp->u.p.cc.len = 0; + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; @@ -2636,6 +2639,9 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) u_flags.async = ASYNC_UNSPECIFIED; u_flags.round = ROUND_UNSPECIFIED; u_flags.sign = SIGN_UNSPECIFIED; + u_flags.share = SHARE_UNSPECIFIED; + u_flags.cc = CC_UNSPECIFIED; + u_flags.readonly = 0; u_flags.status = STATUS_UNKNOWN; @@ -3349,7 +3355,7 @@ next_record_r (st_parameter_dt *dtp, int done) } break; } - else + else if (dtp->u.p.current_unit->flags.cc != CC_NONE) { do { @@ -3531,6 +3537,30 @@ sset (stream * s, int c, ssize_t nbyte) } +/* Finish up a record according to the legacy carriagecontrol type, based + on the first character in the record. */ + +static void +next_record_cc (st_parameter_dt *dtp) +{ + /* Only valid with CARRIAGECONTROL=FORTRAN. */ + if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN) + return; + + fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); + if (dtp->u.p.cc.len > 0) + { + char * p = fbuf_alloc (dtp->u.p.current_unit, dtp->u.p.cc.len); + if (!p) + generate_error (&dtp->common, LIBERROR_OS, NULL); + + /* Output CR for the first character with default CC setting. */ + *(p++) = dtp->u.p.cc.u.end; + if (dtp->u.p.cc.len > 1) + *p = dtp->u.p.cc.u.end; + } +} + /* Position to the next record in write mode. */ static void @@ -3677,21 +3707,30 @@ next_record_w (st_parameter_dt *dtp, int done) } } } + /* Handle legacy CARRIAGECONTROL line endings. */ + else if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN) + next_record_cc (dtp); else { + /* Skip newlines for CC=CC_NONE. */ + const int len = (dtp->u.p.current_unit->flags.cc == CC_NONE) + ? 0 #ifdef HAVE_CRLF - const int len = 2; + : 2; #else - const int len = 1; + : 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; + fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); + if (dtp->u.p.current_unit->flags.cc != CC_NONE) + { + char * p = fbuf_alloc (dtp->u.p.current_unit, len); + if (!p) + goto io_error; #ifdef HAVE_CRLF - *(p++) = '\r'; + *(p++) = '\r'; #endif - *p = '\n'; + *p = '\n'; + } if (is_stream_io (dtp)) { dtp->u.p.current_unit->strm_pos += len; diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index 41cd52f2606..6fa264c4e5c 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -652,6 +652,8 @@ init_units (void) u->flags.encoding = ENCODING_DEFAULT; u->flags.async = ASYNC_NO; u->flags.round = ROUND_UNSPECIFIED; + u->flags.share = SHARE_UNSPECIFIED; + u->flags.cc = CC_LIST; u->recl = options.default_recl; u->endfile = NO_ENDFILE; @@ -681,6 +683,8 @@ init_units (void) u->flags.encoding = ENCODING_DEFAULT; u->flags.async = ASYNC_NO; u->flags.round = ROUND_UNSPECIFIED; + u->flags.share = SHARE_UNSPECIFIED; + u->flags.cc = CC_LIST; u->recl = options.default_recl; u->endfile = AT_ENDFILE; @@ -709,6 +713,8 @@ init_units (void) u->flags.encoding = ENCODING_DEFAULT; u->flags.async = ASYNC_NO; u->flags.round = ROUND_UNSPECIFIED; + u->flags.share = SHARE_UNSPECIFIED; + u->flags.cc = CC_LIST; u->recl = options.default_recl; u->endfile = AT_ENDFILE; diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c index 1e84c42dd3a..5301b847840 100644 --- a/libgfortran/io/unix.c +++ b/libgfortran/io/unix.c @@ -1425,6 +1425,56 @@ regular_file2 (const char *path, st_parameter_open *opp, unit_flags *flags) } +/* Lock the file, if necessary, based on SHARE flags. */ + +#if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK) +static int +open_share (st_parameter_open *opp, int fd, unit_flags *flags) +{ + int r = 0; + struct flock f; + if (fd == STDOUT_FILENO || fd == STDERR_FILENO || fd == STDIN_FILENO) + return 0; + + f.l_start = 0; + f.l_len = 0; + f.l_whence = SEEK_SET; + + switch (flags->share) + { + case SHARE_DENYNONE: + f.l_type = F_RDLCK; + r = fcntl (fd, F_SETLK, &f); + break; + case SHARE_DENYRW: + /* Must be writable to hold write lock. */ + if (flags->action == ACTION_READ) + { + generate_error (&opp->common, LIBERROR_BAD_ACTION, + "Cannot set write lock on file opened for READ"); + return -1; + } + f.l_type = F_WRLCK; + r = fcntl (fd, F_SETLK, &f); + break; + case SHARE_UNSPECIFIED: + default: + break; + } + + return r; +} +#else +static int +open_share (st_parameter_open *opp __attribute__ ((unused)), + int fd __attribute__ ((unused)), + unit_flags *flags __attribute__ ((unused))) +{ + return 0; +} +#endif /* defined(HAVE_FCNTL) ... */ + + /* Wrapper around regular_file2, to make sure we free the path after we're done. */ @@ -1450,7 +1500,7 @@ open_external (st_parameter_open *opp, unit_flags *flags) { fd = tempfile (opp); if (flags->action == ACTION_UNSPECIFIED) - flags->action = ACTION_READWRITE; + flags->action = flags->readonly ? ACTION_READ : ACTION_READWRITE; #if HAVE_UNLINK_OPEN_FILE /* We can unlink scratch files now and it will go away when closed. */ @@ -1472,6 +1522,9 @@ open_external (st_parameter_open *opp, unit_flags *flags) return NULL; fd = fix_fd (fd); + if (open_share (opp, fd, flags) < 0) + return NULL; + return fd_to_stream (fd, flags->form == FORM_UNFORMATTED); } @@ -1752,6 +1805,40 @@ flush_all_units (void) } +/* Unlock the unit if necessary, based on SHARE flags. */ + +int +close_share (gfc_unit *u __attribute__ ((unused))) +{ + int r = 0; +#if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK) + unix_stream *s = (unix_stream *) u->s; + int fd = s->fd; + struct flock f; + + switch (u->flags.share) + { + case SHARE_DENYRW: + case SHARE_DENYNONE: + if (fd != STDOUT_FILENO && fd != STDERR_FILENO && fd != STDIN_FILENO) + { + f.l_start = 0; + f.l_len = 0; + f.l_whence = SEEK_SET; + f.l_type = F_UNLCK; + r = fcntl (fd, F_SETLK, &f); + } + break; + case SHARE_UNSPECIFIED: + default: + break; + } + +#endif + return r; +} + + /* file_exists()-- Returns nonzero if the current filename exists on * the system */ diff --git a/libgfortran/io/unix.h b/libgfortran/io/unix.h index 6b1b02eb65d..3d4de261494 100644 --- a/libgfortran/io/unix.h +++ b/libgfortran/io/unix.h @@ -141,6 +141,9 @@ internal_proto(compare_file_filename); extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len); internal_proto(find_file); +extern int close_share (gfc_unit *); +internal_proto(close_share); + extern int file_exists (const char *file, gfc_charlen_type file_len); internal_proto(file_exists); diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index d4b1bc895ed..c8bba3c0bb8 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -228,6 +228,138 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source, } +/* Check the first character in source if we are using CC_FORTRAN + and set the cc.type appropriately. The cc.type is used later by write_cc + to determine the output start-of-record, and next_record_cc to determine the + output end-of-record. + This function is called before the output buffer is allocated, so alloc_len + is set to the appropriate size to allocate. */ + +static void +write_check_cc (st_parameter_dt *dtp, const char **source, int *alloc_len) +{ + /* Only valid for CARRIAGECONTROL=FORTRAN. */ + if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN + || alloc_len == NULL || source == NULL) + return; + + /* Peek at the first character. */ + int c = (*alloc_len > 0) ? (*source)[0] : EOF; + if (c != EOF) + { + /* The start-of-record character which will be printed. */ + dtp->u.p.cc.u.start = '\n'; + /* The number of characters to print at the start-of-record. + len > 1 means copy the SOR character multiple times. + len == 0 means no SOR will be output. */ + dtp->u.p.cc.len = 1; + + switch (c) + { + case '+': + dtp->u.p.cc.type = CCF_OVERPRINT; + dtp->u.p.cc.len = 0; + break; + case '-': + dtp->u.p.cc.type = CCF_ONE_LF; + dtp->u.p.cc.len = 1; + break; + case '0': + dtp->u.p.cc.type = CCF_TWO_LF; + dtp->u.p.cc.len = 2; + break; + case '1': + dtp->u.p.cc.type = CCF_PAGE_FEED; + dtp->u.p.cc.len = 1; + dtp->u.p.cc.u.start = '\f'; + break; + case '$': + dtp->u.p.cc.type = CCF_PROMPT; + dtp->u.p.cc.len = 1; + break; + case '\0': + dtp->u.p.cc.type = CCF_OVERPRINT_NOA; + dtp->u.p.cc.len = 0; + break; + default: + /* In the default case we copy ONE_LF. */ + dtp->u.p.cc.type = CCF_DEFAULT; + dtp->u.p.cc.len = 1; + break; + } + + /* We add n-1 to alloc_len so our write buffer is the right size. + We are replacing the first character, and possibly prepending some + additional characters. Note for n==0, we actually subtract one from + alloc_len, which is correct, since that character is skipped. */ + if (*alloc_len > 0) + { + *source += 1; + *alloc_len += dtp->u.p.cc.len - 1; + } + /* If we have no input, there is no first character to replace. Make + sure we still allocate enough space for the start-of-record string. */ + else + *alloc_len = dtp->u.p.cc.len; + } +} + + +/* Write the start-of-record character(s) for CC_FORTRAN. + Also adjusts the 'cc' struct to contain the end-of-record character + for next_record_cc. + The source_len is set to the remaining length to copy from the source, + after the start-of-record string was inserted. */ + +static char * +write_cc (st_parameter_dt *dtp, char *p, int *source_len) +{ + /* Only valid for CARRIAGECONTROL=FORTRAN. */ + if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN || source_len == NULL) + return p; + + /* Write the start-of-record string to the output buffer. Note that len is + never more than 2. */ + if (dtp->u.p.cc.len > 0) + { + *(p++) = dtp->u.p.cc.u.start; + if (dtp->u.p.cc.len > 1) + *(p++) = dtp->u.p.cc.u.start; + + /* source_len comes from write_check_cc where it is set to the full + allocated length of the output buffer. Therefore we subtract off the + length of the SOR string to obtain the remaining source length. */ + *source_len -= dtp->u.p.cc.len; + } + + /* Common case. */ + dtp->u.p.cc.len = 1; + dtp->u.p.cc.u.end = '\r'; + + /* Update end-of-record character for next_record_w. */ + switch (dtp->u.p.cc.type) + { + case CCF_PROMPT: + case CCF_OVERPRINT_NOA: + /* No end-of-record. */ + dtp->u.p.cc.len = 0; + dtp->u.p.cc.u.end = '\0'; + break; + case CCF_OVERPRINT: + case CCF_ONE_LF: + case CCF_TWO_LF: + case CCF_PAGE_FEED: + case CCF_DEFAULT: + default: + /* Carriage return. */ + dtp->u.p.cc.len = 1; + dtp->u.p.cc.u.end = '\r'; + break; + } + + return p; +} + void write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len) { @@ -296,10 +428,16 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len) else { #endif + if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN) + write_check_cc (dtp, &source, &wlen); + p = write_block (dtp, wlen); if (p == NULL) return; + if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN) + p = write_cc (dtp, p, &wlen); + if (unlikely (is_char4_unit (dtp))) { gfc_char4_t *p4 = (gfc_char4_t *) p; @@ -1726,7 +1864,8 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, if (dtp->u.p.first_item) { dtp->u.p.first_item = 0; - write_char (dtp, ' '); + if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN) + write_char (dtp, ' '); } else { diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 79f0d61c8e5..b9f24715daa 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -609,6 +609,7 @@ st_parameter_common; #define IOPARM_COMMON_MASK ((1 << 7) - 1) +/* Make sure to keep in sync with io/io.h (st_parameter_open). */ #define IOPARM_OPEN_HAS_RECL_IN (1 << 7) #define IOPARM_OPEN_HAS_FILE (1 << 8) #define IOPARM_OPEN_HAS_STATUS (1 << 9) @@ -626,6 +627,9 @@ st_parameter_common; #define IOPARM_OPEN_HAS_SIGN (1 << 21) #define IOPARM_OPEN_HAS_ASYNCHRONOUS (1 << 22) #define IOPARM_OPEN_HAS_NEWUNIT (1 << 23) +#define IOPARM_OPEN_HAS_READONLY (1 << 24) +#define IOPARM_OPEN_HAS_CC (1 << 25) +#define IOPARM_OPEN_HAS_SHARE (1 << 26) /* library start function and end macro. These can be expanded if needed in the future. cmp is st_parameter_common *cmp */