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

7 files changed, 304 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);