OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

New I/O specifiers CARRIAGECONTROL, READONLY, SHARE with -fdec. 

gcc/fortran/
	* gfortran.texi: Document.
	* 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.

	libgfortran/io/
	* libgfortran.h (IOPARM_OPEN_HAS_READONLY, IOPARM_OPEN_HAS_SHARE,
	IOPARM_OPEN_HAS_CC): New for READONLY, SHARE, and CARRIAGECONTROL.
	* close.c (st_close): Support READONLY.
	* io.h (st_parameter_open, unit_flags): Support SHARE, CARRIAGECONTROL,
	and READONLY.
	* open.c (st_open): Ditto.
	* transfer.c (data_transfer_init): Ditto.
	* io.h (st_parameter_dt): New member 'cc' for CARRIAGECONTROL.
	* write.c (write_check_cc, write_cc): New functions for CARRIAGECONTROL.
	* transfer.c (next_record_cc): Ditto.
	* file_pos.c (st_endfile): Support SHARE and CARRIAGECONTROL.
	* io.h (st_parameter_inquire): Ditto.
	* open.c (edit_modes, new_unit): Ditto.
	* inquire.c (inquire_via_unit, inquire_via_filename): Ditto.
	* io.h (unit_share, unit_cc, cc_fortran, IOPARM_INQUIRE_HAS_SHARE,
	IOPARM_INQUIRE_HAS_CC): New for SHARE and CARRIAGECONTROL.
	* open.c (share_opt, cc_opt): Ditto.
	* read.c (read_x): Support CARRIAGECONTROL.
	* transfer.c (read_sf, next_record_r, next_record_w): Ditto.
	* write.c (list_formatted_write_scalar, write_a): Ditto.
	* unix.h (close_share): New prototype.
	* unix.c (open_share, close_share): New functions to handle SHARE.
	* unix.c (open_external): Handle READONLY. Call open_share.
	* close.c (st_close): Call close_share.

	gcc/testsuite/
	* dec_io_1.f90: New test.
        * dec_io_2.f90: New test.
        * dec_io_3.f90: New test.
        * dec_io_4.f90: New test.
        * dec_io_5.f90: New test.
        * dec_io_6.f90: New test.

From-SVN: r241550
This commit is contained in:
Fritz Reese 2016-10-26 12:11:44 +00:00 committed by Fritz Reese
parent 9dbe100a41
commit 0ef33d4462
27 changed files with 1072 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/fortran/ChangeLog
View File

@ -1,3 +1,14 @@
2016-10-26 Fritz Reese <fritzoreese@gmail.com>
* 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 <fritzoreese@gmail.com>
* gfortran.texi: Document.

2
gcc/fortran/frontend-passes.c
View File

@ -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:

6
gcc/fortran/gfortran.h
View File

@ -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;

92
gcc/fortran/gfortran.texi
View File

@ -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::

177
gcc/fortran/io.c
View File

@ -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))

6
gcc/fortran/ioparm.def
View File

@ -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
<http://www.gnu.org/licenses/>. */
/* 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)

15
gcc/fortran/trans-io.c
View File

@ -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);

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
2016-10-26 Fritz Reese <fritzoreese@gmail.com>
* 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 <jakub@redhat.com>
PR sanitizer/78106

101
gcc/testsuite/gfortran.dg/dec_io_1.f90 Normal file
View File

@ -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'
!!!! <default>
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

104
gcc/testsuite/gfortran.dg/dec_io_2.f90 Normal file
View File

@ -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: <text> CR
! '-' One line feed: NL <text> CR
! '0' Two line feeds: NL NL <text> CR
! '1' Next page: FF <text> CR
! '$' Prompting: NL <text>
!'\0' Overprinting with no advance: <text>
! Other: defaults to Overprinting <text> 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

15
gcc/testsuite/gfortran.dg/dec_io_3.f90 Normal file
View File

@ -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

17
gcc/testsuite/gfortran.dg/dec_io_4.f90 Normal file
View File

@ -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

17
gcc/testsuite/gfortran.dg/dec_io_5.f90 Normal file
View File

@ -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

15
gcc/testsuite/gfortran.dg/dec_io_6.f90 Normal file
View File

@ -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

28
libgfortran/ChangeLog
View File

@ -1,3 +1,31 @@
2016-10-26 Fritz Reese <fritzoreese@gmail.com>
* 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 <jvdelisle@gcc.gnu.org>
PR fortran/77828

16
libgfortran/io/close.c
View File

@ -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);

2
libgfortran/io/file_pos.c
View File

@ -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;

58
libgfortran/io/inquire.c
View File

@ -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)

51
libgfortran/io/io.h
View File

@ -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;

47
libgfortran/io/open.c
View File

@ -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

3
libgfortran/io/read.c
View File

@ -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;

59
libgfortran/io/transfer.c
View File

@ -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;

6
libgfortran/io/unit.c
View File

@ -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;

89
libgfortran/io/unix.c
View File

@ -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 */

3
libgfortran/io/unix.h
View File

@ -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);

141
libgfortran/io/write.c
View File

@ -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
{

4
libgfortran/libgfortran.h
View File

@ -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 */