[multiple changes]

2013-04-12  Robert Dewar  <dewar@adacore.com>

	* opt.ads (Style_Check_Main): New switch.
	* sem.adb (Semantics): Set Style_Check flag properly for new
	unit to be analyzed.
	* sem_ch10.adb (Analyze_With_Clause): Don't reset Style_Check,
	the proper setting of this flag is now part of the Semantics
	procedure.
	* switch-c.adb (Scan_Front_End_Switches): Set Style_Check_Main
	for -gnatg and -gnaty

2013-04-12  Doug Rupp  <rupp@adacore.com>

	* s-crtl.ads (fopen, freopen): Add vms_form parameter
	* i-cstrea.ads (fopen, freopen): Likewise.
	* adaint.h (__gnat_fopen, __gnat_freopen): Likewise.
	* adaint.c (__gnat_fopen, __gnat_freopen): Likewise.
	[VMS]: Split out RMS keys and call CRTL function appropriately.
	* s-fileio.adb (Form_VMS_RMS_Keys, Form_RMS_Context_Key): New
	subprograms.
	(Open, Reset): Call Form_VMS_RMS_Keys. Call fopen,freopen with
	vms_form
	* gnat_rm.texi: Document implemented RMS keys.

From-SVN: r197902

gcc/ada/ChangeLog

+2013-04-12  Robert Dewar  <dewar@adacore.com>
+
+	* opt.ads (Style_Check_Main): New switch.
+	* sem.adb (Semantics): Set Style_Check flag properly for new
+	unit to be analyzed.
+	* sem_ch10.adb (Analyze_With_Clause): Don't reset Style_Check,
+	the proper setting of this flag is now part of the Semantics
+	procedure.
+	* switch-c.adb (Scan_Front_End_Switches): Set Style_Check_Main
+	for -gnatg and -gnaty
+
+2013-04-12  Doug Rupp  <rupp@adacore.com>
+
+	* s-crtl.ads (fopen, freopen): Add vms_form parameter
+	* i-cstrea.ads (fopen, freopen): Likewise.
+	* adaint.h (__gnat_fopen, __gnat_freopen): Likewise.
+	* adaint.c (__gnat_fopen, __gnat_freopen): Likewise.
+	[VMS]: Split out RMS keys and call CRTL function appropriately.
+	* s-fileio.adb (Form_VMS_RMS_Keys, Form_RMS_Context_Key): New
+	subprograms.
+	(Open, Reset): Call Form_VMS_RMS_Keys. Call fopen,freopen with
+	vms_form
+	* gnat_rm.texi: Document implemented RMS keys.
+
 2013-04-12  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_ch13.adb (Analyze_Aspect_Specifications):

gcc/ada/adaint.c

@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *          Copyright (C) 1992-2012, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2013, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -213,6 +213,8 @@ struct vstring
 
 #define SYI$_ACTIVECPU_CNT 0x111e
 extern int LIB$GETSYI (int *, unsigned int *);
+extern unsigned int LIB$CALLG_64
+ ( unsigned long long argument_list [], int (*user_procedure)(void));
 
 #else
 #include <utime.h>
@@ -820,7 +822,8 @@ __gnat_rmdir (char *path)
 }
 
 FILE *
-__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED)
+__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED,
+              char *vms_form ATTRIBUTE_UNUSED)
 {
 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
   TCHAR wpath[GNAT_MAX_PATH_LEN];
@@ -837,7 +840,37 @@ __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED)
 
   return _tfopen (wpath, wmode);
 #elif defined (VMS)
-  return decc$fopen (path, mode);
+  if (vms_form == 0)
+    return decc$fopen (path, mode);
+  else
+    {
+       char *local_form = (char *) alloca (strlen (vms_form) + 1);
+       /* Allocate an argument list of guaranteed ample length.  */
+       unsigned long long *arg_list =
+        (unsigned long long *) alloca (strlen (vms_form) + 3);
+       char *ptrb, *ptre;
+       int i;
+
+       arg_list [1] = (unsigned long long) path;
+       arg_list [2] = (unsigned long long) mode;
+       strcpy (local_form, vms_form);
+
+       /* Given a string such as "\"rfm=udf\",\"rat=cr\""
+          Split it into an argument list as "rfm=udf","rat=cr".  */
+       ptrb = local_form;
+       for (i = 0; *ptrb; i++)
+         {
+            ptrb = strchr (ptrb, '"');
+            ptre = strchr (ptrb + 1, '"');
+            *ptre = 0;
+            arg_list [i + 3] = (unsigned long long) (ptrb + 1);
+            ptrb = ptre + 1;
+         }
+       arg_list [0] = i + 2;
+       /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
+          always a 32bit pointer.   */
+       return LIB$CALLG_64 (arg_list, &decc$fopen);
+    }
 #else
   return GNAT_FOPEN (path, mode);
 #endif
@@ -847,7 +880,8 @@ FILE *
 __gnat_freopen (char *path,
 		char *mode,
 		FILE *stream,
-		int encoding ATTRIBUTE_UNUSED)
+		int encoding ATTRIBUTE_UNUSED,
+                char *vms_form ATTRIBUTE_UNUSED)
 {
 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
   TCHAR wpath[GNAT_MAX_PATH_LEN];
@@ -864,7 +898,38 @@ __gnat_freopen (char *path,
 
   return _tfreopen (wpath, wmode, stream);
 #elif defined (VMS)
-  return decc$freopen (path, mode, stream);
+  if (vms_form == 0)
+    return decc$freopen (path, mode, stream);
+  else
+    {
+       char *local_form = (char *) alloca (strlen (vms_form) + 1);
+       /* Allocate an argument list of guaranteed ample length.  */
+       unsigned long long *arg_list =
+        (unsigned long long *) alloca (strlen (vms_form) + 4);
+       char *ptrb, *ptre;
+       int i;
+
+       arg_list [1] = (unsigned long long) path;
+       arg_list [2] = (unsigned long long) mode;
+       arg_list [3] = (unsigned long long) stream;
+       strcpy (local_form, vms_form);
+
+       /* Given a string such as "\"rfm=udf\",\"rat=cr\""
+          Split it into an argument list as "rfm=udf","rat=cr".  */
+       ptrb = local_form;
+       for (i = 0; *ptrb; i++)
+         {
+            ptrb = strchr (ptrb, '"');
+            ptre = strchr (ptrb + 1, '"');
+            *ptre = 0;
+            arg_list [i + 4] = (unsigned long long) (ptrb + 1);
+            ptrb = ptre + 1;
+         }
+       arg_list [0] = i + 3;
+       /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
+          always a 32bit pointer.   */
+       return LIB$CALLG_64 (arg_list, &decc$freopen);
+    }
 #else
   return freopen (path, mode, stream);
 #endif

gcc/ada/adaint.h

@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *          Copyright (C) 1992-2012, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2013, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -128,9 +128,10 @@ extern int    __gnat_rename                        (char *, char *);
 extern int    __gnat_chdir                         (char *);
 extern int    __gnat_rmdir                         (char *);
 
-extern FILE  *__gnat_fopen			   (char *, char *, int);
+extern FILE  *__gnat_fopen			   (char *, char *, int,
+						    char *);
 extern FILE  *__gnat_freopen			   (char *, char *, FILE *,
-				                    int);
+				                    int, char *);
 extern int    __gnat_open_read                     (char *, int);
 extern int    __gnat_open_rw                       (char *, int);
 extern int    __gnat_open_create                   (char *, int);

gcc/ada/gnat_rm.texi

@@ -14261,6 +14261,25 @@ The use of these parameters is described later in this section. If an
 unrecognized keyword appears in a form string, it is silently ignored
 and not considered invalid.
 
+@noindent
+For OpenVMS additional FORM string keywords are available for use with
+RMS services.  The syntax is:
+
+@smallexample
+VMS_RMS_Keys=(keyword=value,@dots{},keyword=value)
+@end smallexample
+
+@noindent
+The following RMS keywords and values are currently defined:
+
+@smallexample
+Context=Force_Stream_Mode|Force_Record_Mode
+@end smallexample
+
+@noindent
+VMS RMS keys are silently ignored on non-VMS systems.  On OpenVMS
+unimplented RMS keywords, values, or invalid syntax will raise Use_Error.
+
 @node Direct_IO
 @section Direct_IO
 

gcc/ada/i-cstrea.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1995-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1995-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -107,8 +107,8 @@ package Interfaces.C_Streams is
    function fopen
      (filename : chars;
       mode     : chars;
-      encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8)
-      return FILEs
+      encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8;
+      vms_form : chars := System.Null_Address) return FILEs
      renames System.CRTL.fopen;
    --  Note: to maintain target independence, use text_translation_required,
    --  a boolean variable defined in sysdep.c to deal with the target
@@ -144,8 +144,8 @@ package Interfaces.C_Streams is
      (filename : chars;
       mode     : chars;
       stream   : FILEs;
-      encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8)
-      return FILEs
+      encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8;
+      vms_form : chars := System.Null_Address) return FILEs
      renames System.CRTL.freopen;
 
    function fseek

gcc/ada/opt.ads

@@ -1267,7 +1267,15 @@ package Opt is
    --  GNAT
    --  Set True to perform style checks. Activates checks carried out in
    --  package Style (see body of this package for details of checks). This
-   --  flag is set True by either the -gnatg or -gnaty switches.
+   --  flag is set True by use of either the -gnatg or -gnaty switches, or
+   --  by the Style_Check pragma.
+
+   Style_Check_Main : Boolean := False;
+   --  GNAT
+   --  Set True if Style_Check was set for the main unit. This is used to
+   --  renable style checks for units in the mail extended source that get
+   --  with'ed indirectly. It is set on by use of either the -gnatg or -gnaty
+   --  switches, but not by use of the Style_Checks pragma.
 
    Suppress_All_Inlining : Boolean := False;
    --  GNAT

gcc/ada/s-crtl.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2003-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 2003-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -97,7 +97,8 @@ package System.CRTL is
    function fopen
      (filename : chars;
       mode     : chars;
-      encoding : Filename_Encoding := Unspecified) return FILEs;
+      encoding : Filename_Encoding := Unspecified;
+      vms_form : chars := System.Null_Address) return FILEs;
    pragma Import (C, fopen, "__gnat_fopen");
 
    function fputc (C : int; stream : FILEs) return int;
@@ -113,7 +114,8 @@ package System.CRTL is
      (filename : chars;
       mode     : chars;
       stream   : FILEs;
-      encoding : Filename_Encoding := Unspecified) return FILEs;
+      encoding : Filename_Encoding := Unspecified;
+      vms_form : chars := System.Null_Address) return FILEs;
    pragma Import (C, freopen, "__gnat_freopen");
 
    function fseek

gcc/ada/sem.adb

@@ -1311,6 +1311,7 @@ package body Sem is
       S_In_Spec_Expr      : constant Boolean          := In_Spec_Expression;
       S_Inside_A_Generic  : constant Boolean          := Inside_A_Generic;
       S_Outer_Gen_Scope   : constant Entity_Id        := Outer_Generic_Scope;
+      S_Style_Check       : constant Boolean          := Style_Check;
 
       Generic_Main : constant Boolean :=
                        Nkind (Unit (Cunit (Main_Unit)))
@@ -1318,6 +1319,10 @@ package body Sem is
       --  If the main unit is generic, every compiled unit, including its
       --  context, is compiled with expansion disabled.
 
+      Ext_Main_Source_Unit : constant Boolean :=
+                               In_Extended_Main_Source_Unit (Comp_Unit);
+      --  Determine if unit is in extended main source unit
+
       Save_Config_Switches : Config_Switches_Type;
       --  Variable used to save values of config switches while we analyze the
       --  new unit, to be restored on exit for proper recursive behavior.
@@ -1386,9 +1391,6 @@ package body Sem is
       --  Sequential_IO) as this would prevent pragma Extend_System from being
       --  taken into account, for example when Text_IO is renaming DEC.Text_IO.
 
-      --  Cleaner might be to do the kludge at the point of excluding the
-      --  pragma (do not exclude for renamings ???)
-
       if Is_Predefined_File_Name
            (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
       then
@@ -1423,12 +1425,28 @@ package body Sem is
       --  For unit in main extended unit, we reset the configuration values
       --  for the non-partition-wide restrictions. For other units reset them.
 
-      if In_Extended_Main_Source_Unit (Comp_Unit) then
+      if Ext_Main_Source_Unit then
          Restore_Config_Cunit_Boolean_Restrictions;
       else
          Reset_Cunit_Boolean_Restrictions;
       end if;
 
+      --  Turn off style checks for unit that is not in the extended main
+      --  source unit. This improves processing efficiency for such units
+      --  (for which we don't want style checks anyway, and where they will
+      --  get suppressed), and is definitely needed to stop some style checks
+      --  from invading the run-time units (e.g. overriding checks).
+
+      if not Ext_Main_Source_Unit then
+         Style_Check := False;
+
+      --  If this is part of the extended main source unit, set style check
+      --  mode to match the style check mode of the main source unit itself.
+
+      else
+         Style_Check := Style_Check_Main;
+      end if;
+
       --  Only do analysis of unit that has not already been analyzed
 
       if not Analyzed (Comp_Unit) then
@@ -1482,6 +1500,7 @@ package body Sem is
       In_Spec_Expression   := S_In_Spec_Expr;
       Inside_A_Generic     := S_Inside_A_Generic;
       Outer_Generic_Scope  := S_Outer_Gen_Scope;
+      Style_Check          := S_Style_Check;
 
       Restore_Opt_Config_Switches (Save_Config_Switches);
 

gcc/ada/sem_ch10.adb

@@ -2457,14 +2457,6 @@ package body Sem_Ch10 is
          return;
       end if;
 
-      --  We reset ordinary style checking during the analysis of a with'ed
-      --  unit, but we do NOT reset GNAT special analysis mode (the latter
-      --  definitely *does* apply to with'ed units).
-
-      if not GNAT_Mode then
-         Style_Check := False;
-      end if;
-
       --  If the library unit is a predefined unit, and we are in high
       --  integrity mode, then temporarily reset Configurable_Run_Time_Mode
       --  for the analysis of the with'ed unit. This mode does not prevent

gcc/ada/switch-c.adb

@@ -751,6 +751,7 @@ package body Switch.C is
                Identifier_Character_Set := 'n';
                System_Extend_Unit := Empty;
                Warning_Mode := Treat_As_Error;
+               Style_Check_Main := True;
 
                --  Set Ada 2012 mode explicitly. We don't want to rely on the
                --  implicit setting here, since for example, we want
@@ -1173,6 +1174,7 @@ package body Switch.C is
 
             when 'y' =>
                Ptr := Ptr + 1;
+               Style_Check_Main := True;
 
                if Ptr > Max then
                   Set_Default_Style_Check_Options;