aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog11
-rw-r--r--gcc/fortran/frontend-passes.c2
-rw-r--r--gcc/fortran/gfortran.h6
-rw-r--r--gcc/fortran/gfortran.texi92
-rw-r--r--gcc/fortran/io.c177
-rw-r--r--gcc/fortran/ioparm.def6
-rw-r--r--gcc/fortran/trans-io.c15
-rw-r--r--gcc/testsuite/ChangeLog9
-rw-r--r--gcc/testsuite/gfortran.dg/dec_io_1.f90101
-rw-r--r--gcc/testsuite/gfortran.dg/dec_io_2.f90104
-rw-r--r--gcc/testsuite/gfortran.dg/dec_io_3.f9015
-rw-r--r--gcc/testsuite/gfortran.dg/dec_io_4.f9017
-rw-r--r--gcc/testsuite/gfortran.dg/dec_io_5.f9017
-rw-r--r--gcc/testsuite/gfortran.dg/dec_io_6.f9015
14 files changed, 582 insertions, 5 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f517550..65911dc 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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.
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 53b3c54..e61673f 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 37423b75..ea4437c 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 0278bd6..e65c2de 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 7c48c49..dce0f7c 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 bd628ce..f1bf733 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
<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)
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index a355ee2..285e551 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 6e36b43..d27d57a 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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
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 0000000..c7f59d6
--- /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'
+
+!!!! <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
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 0000000..9adc4f4
--- /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: <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
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 0000000..d37961c
--- /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 0000000..9b8fbc9
--- /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 0000000..9d44c6e
--- /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 0000000..a0c0256
--- /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
generated by cgit v1.1 at 2025-05-31 13:21:53 +0000