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

gcc/fortran/ChangeLog

+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.

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:

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;
 

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

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,16 +2135,30 @@ 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.  */
   if (open->asynchronous)
@@ -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))

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)

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

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/dec_io_1.f90

+! { 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

gcc/testsuite/gfortran.dg/dec_io_2.f90

+! { 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

gcc/testsuite/gfortran.dg/dec_io_3.f90

+! { 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

gcc/testsuite/gfortran.dg/dec_io_4.f90

+! { 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

gcc/testsuite/gfortran.dg/dec_io_5.f90

+! { 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

gcc/testsuite/gfortran.dg/dec_io_6.f90

+! { 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

libgfortran/ChangeLog

+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

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)
@@ -79,6 +81,11 @@ st_close (st_parameter_close *clp)
 	{
 	  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);
 #else
@@ -86,6 +93,7 @@ st_close (st_parameter_close *clp)
 #endif
 		}
 	    }
+	}
 
       close_unit (u);
 

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;

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)

libgfortran/io/io.h

@@ -269,9 +269,35 @@ typedef enum
 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;
 

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

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;

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,14 +3707,22 @@ 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);
+	  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;
@@ -3692,6 +3730,7 @@ next_record_w (st_parameter_dt *dtp, int done)
 	      *(p++) = '\r';
 #endif
 	      *p = '\n';
+	    }
 	  if (is_stream_io (dtp))
 	    {
 	      dtp->u.p.current_unit->strm_pos += len;

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;

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

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

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,6 +1864,7 @@ 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;
+      if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN)
 	write_char (dtp, ' ');
     }
   else

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