[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

1 files changed, 247 insertions, 9 deletions

diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb
index 88bad49f76e..0eea5367ef4 100644
--- a/gcc/ada/s-fileio.adb
+++ b/gcc/ada/s-fileio.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          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- --
@@ -52,6 +52,11 @@ package body System.File_IO is
    use type Interfaces.C.int;
    use type CRTL.size_t;
 
+   subtype String_Access is System.OS_Lib.String_Access;
+   procedure Free (X : in out String_Access) renames System.OS_Lib.Free;
+   function "=" (X, Y : String_Access) return Boolean
+     renames System.OS_Lib."=";
+
    ----------------------
    -- Global Variables --
    ----------------------
@@ -98,6 +103,9 @@ package body System.File_IO is
      (C, text_translation_required, "__gnat_text_translation_required");
    --  If true, add appropriate suffix to control string for Open
 
+   VMS_Formstr : String_Access := null;
+   --  For special VMS RMS keywords and values.
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -132,11 +140,20 @@ package body System.File_IO is
    --  with Name includes that file name in the message.
 
    procedure Raise_Device_Error
-     (File : AFCB_Ptr; Errno : Integer := OS_Lib.Errno);
+     (File  : AFCB_Ptr;
+      Errno : Integer := OS_Lib.Errno);
    pragma No_Return (Raise_Device_Error);
    --  Clear error indication on File and raise Device_Error with an exception
    --  message providing errno information.
 
+   procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access);
+   --   Parse the RMS Keys
+
+   function Form_RMS_Context_Key
+     (Form     : String;
+      VMS_Form : String_Access) return Natural;
+   --   Parse the RMS Context Key
+
    ----------------
    -- Append_Set --
    ----------------
@@ -640,6 +657,191 @@ package body System.File_IO is
       Stop  := 0;
    end Form_Parameter;
 
+   --------------------------
+   -- Form_RMS_Context_Key --
+   --------------------------
+
+   function Form_RMS_Context_Key
+     (Form     : String;
+      VMS_Form : String_Access) return Natural
+   is
+      type Context_Parms is
+        (Binary_Data, Convert_Fortran_Carriage_Control, Force_Record_Mode,
+         Force_Stream_Mode, Explicit_Write);
+   --  Ada-fied list of all possible Context keyword values.
+
+      Pos   : Natural := 0;
+      Klen  : Natural := 0;
+      Index : Natural;
+
+   begin
+      --  Find the end of the occupation
+
+      for J in VMS_Form'First .. VMS_Form'Last loop
+         if VMS_Form (J) = ASCII.NUL then
+            Pos := J;
+            exit;
+         end if;
+      end loop;
+
+      Index := Form'First;
+      while Index < Form'Last loop
+         if Form (Index) = '=' then
+            Index := Index + 1;
+
+            --  Loop through the context values and look for a match
+
+            for Parm in Context_Parms loop
+               declare
+                  KImage : String := Context_Parms'Image (Parm);
+
+               begin
+                  Klen := KImage'Length;
+                  To_Lower (KImage);
+
+                  if Form (Index .. Index + Klen - 1) = KImage then
+                     case Parm is
+                        when Force_Record_Mode =>
+                           VMS_Form (Pos) := '"';
+                           Pos := Pos + 1;
+                           VMS_Form (Pos .. Pos + 7) := "ctx=rec";
+                           Pos := Pos + 7;
+                           VMS_Form (Pos) := '"';
+                           Pos := Pos + 1;
+                           VMS_Form (Pos) := ',';
+                           return Index + Klen;
+
+                        when Force_Stream_Mode =>
+                           VMS_Form (Pos) := '"';
+                           Pos := Pos + 1;
+                           VMS_Form (Pos .. Pos + 7) := "ctx=stm";
+                           Pos := Pos + 7;
+                           VMS_Form (Pos) := '"';
+                           Pos := Pos + 1;
+                           VMS_Form (Pos) := ',';
+                           return Index + Klen;
+
+                        when others =>
+                           raise Use_Error
+                             with "unimplemented RMS Context Value";
+                     end case;
+                  end if;
+               end;
+            end loop;
+
+            raise Use_Error with "unrecognized RMS Context Value";
+         end if;
+      end loop;
+
+      raise Use_Error with "malformed RMS Context Value";
+   end Form_RMS_Context_Key;
+
+   -----------------------
+   -- Form_VMS_RMS_Keys --
+   -----------------------
+
+   procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access)
+   is
+      VMS_RMS_Keys_Token : constant String := "vms_rms_keys";
+      Klen : Natural := VMS_RMS_Keys_Token'Length;
+      Index : Natural;
+
+      --  Ada-fied list of all RMS keywords, translated from the
+      --  HP C Run-Time Library Reference Manual, Table REF-3:
+      --  RMS Valid Keywords and Values
+
+      type RMS_Keys is
+       (Access_Callback, Allocation_Quantity, Block_Size, Context,
+        Default_Extension_Quantity, Default_File_Name_String, Error_Callback,
+        File_Processing_Options, Fixed_Header_Size, Global_Buffer_Count,
+        Multiblock_Count, Multibuffer_Count, Maximum_Record_Size,
+        Terminal_Input_Prompt, Record_Attributes, Record_Format,
+        Record_Processing_Options, Retrieval_Pointer_Count, Sharing_Options,
+        Timeout_IO_Value);
+
+   begin
+      Index := Form'First + Klen - 1;
+      while Index < Form'Last loop
+         Index := Index + 1;
+
+         --  Scan for the token signalling VMS RMS Keys ahead.  Should
+         --  whitespace be eaten???
+
+         if Form (Index - Klen .. Index - 1) = VMS_RMS_Keys_Token then
+
+            --  Allocate the VMS form string that will contain the cryptic
+            --  CRTL RMS strings and initialize it to all nulls.  Since the
+            --  CRTL strings are always shorter than the Ada-fied strings,
+            --  it follows that an allocation of the original size will be
+            --  more than adequate.
+            VMS_Form := new String'(Form (Form'First .. Form'Last));
+            VMS_Form.all := (others => ASCII.NUL);
+
+            if Form (Index) = '=' then
+               Index := Index + 1;
+               if Form (Index) = '(' then
+                  while Index < Form'Last loop
+                     Index := Index + 1;
+
+                     --  Loop through the RMS Keys and dispatch.
+
+                     for Key in RMS_Keys loop
+                        declare
+                           KImage : String := RMS_Keys'Image (Key);
+                        begin
+                           Klen := KImage'Length;
+                           To_Lower (KImage);
+                           if Form (Index .. Index + Klen - 1) = KImage then
+                              case Key is
+
+                                 when Context =>
+                                    Index := Form_RMS_Context_Key
+                                     (Form (Index + Klen .. Form'Last),
+                                      VMS_Form);
+                                    exit;
+
+                                 when others =>
+                                    raise Use_Error
+                                     with "unimplemented VMS RMS Form Key";
+                              end case;
+                           end if;
+                        end;
+                     end loop;
+
+                     if Form (Index) = ')' then
+
+                        --  Done, erase the unneeded trailing comma and
+                        --  return.
+
+                        for J in reverse VMS_Form'First .. VMS_Form'Last loop
+                           if VMS_Form (J) = ',' then
+                              VMS_Form (J) := ASCII.NUL;
+                              return;
+                           end if;
+                        end loop;
+
+                        --  Shouldn't be possible to get here
+                        raise Use_Error;
+
+                     elsif Form (Index) = ',' then
+
+                        --  Another key ahead, exit inner loop
+                        null;
+                     else
+
+                        --  Keyword value not terminated correctly
+                        raise Use_Error with "malformed VMS RMS Form";
+                     end if;
+                  end loop;
+               end if;
+            end if;
+
+            --  Found the keyword, but not followed by correct syntax
+            raise Use_Error with "malformed VMS RMS Form";
+         end if;
+      end loop;
+   end Form_VMS_RMS_Keys;
+
    -------------
    -- Is_Open --
    -------------
@@ -868,6 +1070,17 @@ package body System.File_IO is
            Form_Boolean (Formstr, "text_translation", Default => True);
       end if;
 
+      --  Acquire settings of target specific form parameters on VMS. Only
+      --  Context is currently implemented, for forcing a byte stream mode
+      --  read. On non-VMS systems, the settings are ultimately ignored in
+      --  the implementation of __gnat_fopen.
+
+      --  Should a warning be issued on non-VMS systems?  That's not possible
+      --  without testing System.OpenVMS boolean which isn't present in most
+      --  non-VMS versions of package System.
+
+      Form_VMS_RMS_Keys (Formstr, VMS_Formstr);
+
       --  If we were given a stream (call from xxx.C_Streams.Open), then set
       --  the full name to the given one, and skip to end of processing.
 
@@ -1030,7 +1243,19 @@ package body System.File_IO is
             --  since by the time of the delete, the current working directory
             --  may have changed and we do not want to delete a different file!
 
-            Stream := fopen (Namestr'Address, Fopstr'Address, Encoding);
+            if VMS_Formstr = null then
+               Stream := fopen (Namestr'Address, Fopstr'Address, Encoding,
+                                Null_Address);
+            else
+               Stream := fopen (Namestr'Address, Fopstr'Address, Encoding,
+                                VMS_Formstr.all'Address);
+            end if;
+
+            --   No need to keep this around
+
+            if VMS_Formstr /= null then
+               Free (VMS_Formstr);
+            end if;
 
             if Stream = NULL_Stream then
 
@@ -1042,15 +1267,15 @@ package body System.File_IO is
                declare
                   function Is_File_Not_Found_Error
                     (Errno_Value : Integer) return Integer;
-                  --  Non-zero when the given errno value indicates a non-
-                  --  existing file.
-
                   pragma Import
                     (C, Is_File_Not_Found_Error,
                      "__gnat_is_file_not_found_error");
+                  --  Non-zero when the given errno value indicates a non-
+                  --  existing file.
 
-                  Errno : constant Integer := OS_Lib.Errno;
+                  Errno   : constant Integer := OS_Lib.Errno;
                   Message : constant String := Errno_Message (Name, Errno);
+
                begin
                   if Is_File_Not_Found_Error (Errno) /= 0 then
                      raise Name_Error with Message;
@@ -1196,8 +1421,21 @@ package body System.File_IO is
          Fopen_Mode
            (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
 
-         File.Stream := freopen
-           (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding);
+         Form_VMS_RMS_Keys (File.Form.all, VMS_Formstr);
+
+         if VMS_Formstr = null then
+            File.Stream := freopen
+              (File.Name.all'Address, Fopstr'Address, File.Stream,
+               File.Encoding, Null_Address);
+         else
+            File.Stream := freopen
+              (File.Name.all'Address, Fopstr'Address, File.Stream,
+               File.Encoding, VMS_Formstr.all'Address);
+         end if;
+
+         if VMS_Formstr /= null then
+            Free (VMS_Formstr);
+         end if;
 
          if File.Stream = NULL_Stream then
             Close (File_Ptr);