[multiple changes]

2014-07-30  Hristian Kirtchev  <kirtchev@adacore.com>

	* aspects.ads Aspects Async_Readers, Async_Writers,
	Effective_Reads and Effective_Writes do not need to be delayed.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Propagate the
	optional Boolean expression when generating the corresponding
	pragma for an external property aspect.
	* sem_prag.adb (Analyze_External_Property_In_Decl_Part): Remove
	local constant Obj. Add local constant Obj_Id. Reimplement the
	check which ensures that the related variable is in fact volatile.
	(Analyze_Pragma): Reimplement the analysis of external property pragmas.
	* sem_util.adb (Is_Enabled): New routine.
	(Variable_Has_Enabled_Property): Reimplement the detection of
	an enabled external property.

2014-07-30  Sergey Rybin  <rybin@adacore.com frybin>

	* gnat_ugn.texi, vms_data.ads: gnatstub: describe generating subunits
	for body stubs.

2014-07-30  Pascal Obry  <obry@adacore.com>

	* g-forstr.adb, g-forstr.ads: New.
	* gnat_rm.texi, impunit.adb Makefile.rtl: Add new unit
	GNAT.Formatted_String.

From-SVN: r213241

gcc/ada/ChangeLog

@@ -1,3 +1,29 @@
+2014-07-30  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* aspects.ads Aspects Async_Readers, Async_Writers,
+	Effective_Reads and Effective_Writes do not need to be delayed.
+	* sem_ch13.adb (Analyze_Aspect_Specifications): Propagate the
+	optional Boolean expression when generating the corresponding
+	pragma for an external property aspect.
+	* sem_prag.adb (Analyze_External_Property_In_Decl_Part): Remove
+	local constant Obj. Add local constant Obj_Id. Reimplement the
+	check which ensures that the related variable is in fact volatile.
+	(Analyze_Pragma): Reimplement the analysis of external property pragmas.
+	* sem_util.adb (Is_Enabled): New routine.
+	(Variable_Has_Enabled_Property): Reimplement the detection of
+	an enabled external property.
+
+2014-07-30  Sergey Rybin  <rybin@adacore.com frybin>
+
+	* gnat_ugn.texi, vms_data.ads: gnatstub: describe generating subunits
+	for body stubs.
+
+2014-07-30  Pascal Obry  <obry@adacore.com>
+
+	* g-forstr.adb, g-forstr.ads: New.
+	* gnat_rm.texi, impunit.adb Makefile.rtl: Add new unit
+	GNAT.Formatted_String.
+
 2014-07-30  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* exp_aggr.adb (Aggr_Assignment_OK_For_Backend): New predicate.

gcc/ada/Makefile.rtl

@@ -411,6 +411,7 @@ GNATRTL_NONTASKING_OBJS= \
   g-expect$(objext) \
   g-exptty$(objext) \
   g-flocon$(objext) \
+  g-forstr$(objext) \
   g-heasor$(objext) \
   g-hesora$(objext) \
   g-hesorg$(objext) \

gcc/ada/aspects.ads

@@ -590,8 +590,6 @@ package Aspects is
      (No_Aspect                           => Always_Delay,
       Aspect_Address                      => Always_Delay,
       Aspect_All_Calls_Remote             => Always_Delay,
-      Aspect_Async_Readers                => Always_Delay,
-      Aspect_Async_Writers                => Always_Delay,
       Aspect_Asynchronous                 => Always_Delay,
       Aspect_Attach_Handler               => Always_Delay,
       Aspect_Constant_Indexing            => Always_Delay,
@@ -604,8 +602,6 @@ package Aspects is
       Aspect_Discard_Names                => Always_Delay,
       Aspect_Dispatching_Domain           => Always_Delay,
       Aspect_Dynamic_Predicate            => Always_Delay,
-      Aspect_Effective_Reads              => Always_Delay,
-      Aspect_Effective_Writes             => Always_Delay,
       Aspect_Elaborate_Body               => Always_Delay,
       Aspect_External_Name                => Always_Delay,
       Aspect_External_Tag                 => Always_Delay,
@@ -673,9 +669,13 @@ package Aspects is
 
       Aspect_Abstract_State               => Never_Delay,
       Aspect_Annotate                     => Never_Delay,
+      Aspect_Async_Readers                => Never_Delay,
+      Aspect_Async_Writers                => Never_Delay,
       Aspect_Convention                   => Never_Delay,
       Aspect_Dimension                    => Never_Delay,
       Aspect_Dimension_System             => Never_Delay,
+      Aspect_Effective_Reads              => Never_Delay,
+      Aspect_Effective_Writes             => Never_Delay,
       Aspect_Part_Of                      => Never_Delay,
       Aspect_Refined_Post                 => Never_Delay,
       Aspect_SPARK_Mode                   => Never_Delay,

gcc/ada/g-forstr.adb

@@ -0,0 +1,951 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                G N A T . F O R M A T T E D _ S T R I N G                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--             Copyright (C) 2014, 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- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling;
+with Ada.Float_Text_IO;
+with Ada.Integer_Text_IO;
+with Ada.Long_Float_Text_IO;
+with Ada.Long_Integer_Text_IO;
+with Ada.Strings.Fixed;
+with Ada.Unchecked_Deallocation;
+
+with System.Address_Image;
+
+package body GNAT.Formatted_String is
+
+   type F_Kind is (Decimal_Int,                 -- %d %i
+                   Unsigned_Decimal_Int,        -- %u
+                   Unsigned_Octal,              -- %o
+                   Unsigned_Hexadecimal_Int,    -- %x
+                   Unsigned_Hexadecimal_Int_Up, -- %X
+                   Decimal_Float,               -- %f %F
+                   Decimal_Scientific_Float,    -- %e
+                   Decimal_Scientific_Float_Up, -- %E
+                   Shortest_Decimal_Float,      -- %g
+                   Shortest_Decimal_Float_Up,   -- %G
+                   Char,                        -- %c
+                   Str,                         -- %s
+                   Pointer                      -- %p
+                  );
+
+   type Sign_Kind is (Neg, Zero, Pos);
+
+   subtype Is_Number is F_Kind range Decimal_Int .. Decimal_Float;
+
+   type F_Sign is (If_Neg, Forced, Space) with Default_Value => If_Neg;
+
+   type F_Base is (None, C_Style, Ada_Style) with Default_Value => None;
+
+   Unset    : constant Integer := -1;
+
+   type F_Data is record
+      Kind         : F_Kind;
+      Width        : Natural := 0;
+      Precision    : Integer := Unset;
+      Left_Justify : Boolean := False;
+      Sign         : F_Sign;
+      Base         : F_Base;
+      Zero_Pad     : Boolean := False;
+      Value_Needed : Natural range 0 .. 2 := 0;
+   end record;
+
+   procedure Next_Format
+     (Format : Formatted_String; F_Spec : out F_Data; Start : out Positive);
+   --  Parse the next format specifier, a format specifier has the following
+   --  syntax: %[flags][width][.precision][length]specifier
+
+   function Get_Formatted
+     (F_Spec : F_Data; Value : String; Len : Positive) return String;
+   --  Returns Value formatted given the information in F_Spec
+
+   procedure Raise_Wrong_Format (Format : Formatted_String) with No_Return;
+   --  Raise the Format_Error exception which information about the context
+
+   generic
+      type Flt is private;
+
+      with procedure Put
+        (To   : out String;
+         Item : Flt;
+         Aft  : Text_IO.Field;
+         Exp  : Text_IO.Field);
+   function P_Flt_Format
+     (Format : Formatted_String; Var : Flt) return Formatted_String;
+   --  Generic routine which handles all floating point numbers
+
+   generic
+      type Int is private;
+
+      with function To_Integer (Item : Int) return Integer;
+
+      with function Sign (Item : Int) return Sign_Kind;
+
+      with procedure Put
+        (To   : out String;
+         Item : Int;
+         Base : Text_IO.Number_Base);
+   function P_Int_Format
+     (Format : Formatted_String; Var : Int) return Formatted_String;
+   --  Generic routine which handles all the integer numbers
+
+   ---------
+   -- "+" --
+   ---------
+
+   function "+" (Format : String) return Formatted_String is
+   begin
+      return Formatted_String'
+        (Finalization.Controlled with
+           D => new Data'(Format'Length, 1, Format, 1,
+             Null_Unbounded_String, 0, 0, (0, 0)));
+   end "+";
+
+   ---------
+   -- "-" --
+   ---------
+
+   function "-" (Format : Formatted_String) return String is
+      F : String renames Format.D.Format;
+      I : Natural renames Format.D.Index;
+      R : Unbounded_String := Format.D.Result;
+   begin
+      --  Make sure we get the remaining character up to the next unhandled
+      --  format specifier.
+
+      while (I <= F'Length and then F (I) /= '%')
+        or else (I < F'Length - 1 and then F (I + 1) = '%')
+      loop
+         Append (R, F (I));
+
+         --  If we have two consecutive %, skip the second one
+
+         if F (I) = '%' and then I < F'Length - 1 and then F (I + 1) = '%' then
+            I := I + 1;
+         end if;
+
+         I := I + 1;
+      end loop;
+
+      return To_String (R);
+   end "-";
+
+   ---------
+   -- "&" --
+   ---------
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Character) return Formatted_String
+   is
+      F     : F_Data;
+      Start : Positive;
+   begin
+      Next_Format (Format, F, Start);
+
+      if F.Value_Needed > 0 then
+         Raise_Wrong_Format (Format);
+      end if;
+
+      case F.Kind is
+         when Char =>
+            Append (Format.D.Result, Get_Formatted (F, String'(1 => Var), 1));
+         when others =>
+            Raise_Wrong_Format (Format);
+      end case;
+
+      return Format;
+   end "&";
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : String) return Formatted_String
+   is
+      F     : F_Data;
+      Start : Positive;
+   begin
+      Next_Format (Format, F, Start);
+
+      if F.Value_Needed > 0 then
+         Raise_Wrong_Format (Format);
+      end if;
+
+      case F.Kind is
+         when Str =>
+            declare
+               S : constant String := Get_Formatted (F, Var, Var'Length);
+            begin
+               if F.Precision = Unset then
+                  Append (Format.D.Result, S);
+               else
+                  Append
+                    (Format.D.Result,
+                     S (S'First .. S'First + F.Precision - 1));
+               end if;
+            end;
+
+         when others =>
+            Raise_Wrong_Format (Format);
+      end case;
+
+      return Format;
+   end "&";
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Boolean) return Formatted_String is
+   begin
+      return Format & Boolean'Image (Var);
+   end "&";
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Float) return Formatted_String
+   is
+      function Float_Format is new Flt_Format (Float, Float_Text_IO.Put);
+   begin
+      return Float_Format (Format, Var);
+   end "&";
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Long_Float) return Formatted_String
+   is
+      function Float_Format is
+        new Flt_Format (Long_Float, Long_Float_Text_IO.Put);
+   begin
+      return Float_Format (Format, Var);
+   end "&";
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Duration) return Formatted_String
+   is
+      package Duration_Text_IO is new Text_IO.Fixed_IO (Duration);
+      function Duration_Format is
+        new P_Flt_Format (Duration, Duration_Text_IO.Put);
+   begin
+      return Duration_Format (Format, Var);
+   end "&";
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Integer) return Formatted_String
+   is
+      function Integer_Format is
+        new Int_Format (Integer, Integer_Text_IO.Put);
+   begin
+      return Integer_Format (Format, Var);
+   end "&";
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Long_Integer) return Formatted_String
+   is
+      function Integer_Format is
+        new Int_Format (Long_Integer, Long_Integer_Text_IO.Put);
+   begin
+      return Integer_Format (Format, Var);
+   end "&";
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : System.Address) return Formatted_String
+   is
+      A_Img : constant String := System.Address_Image (Var);
+      F     : F_Data;
+      Start : Positive;
+   begin
+      Next_Format (Format, F, Start);
+
+      if F.Value_Needed > 0 then
+         Raise_Wrong_Format (Format);
+      end if;
+
+      case F.Kind is
+         when Pointer =>
+            Append (Format.D.Result, Get_Formatted (F, A_Img, A_Img'Length));
+         when others =>
+            Raise_Wrong_Format (Format);
+      end case;
+
+      return Format;
+   end "&";
+
+   ------------
+   -- Adjust --
+   ------------
+
+   overriding procedure Adjust (F : in out Formatted_String) is
+   begin
+      F.D.Ref_Count := F.D.Ref_Count + 1;
+   end Adjust;
+
+   --------------------
+   -- Decimal_Format --
+   --------------------
+
+   function Decimal_Format
+     (Format : Formatted_String;
+      Var    : Flt) return Formatted_String
+   is
+      function Flt_Format is new P_Flt_Format (Flt, Put);
+   begin
+      return Flt_Format (Format, Var);
+   end Decimal_Format;
+
+   -----------------
+   -- Enum_Format --
+   -----------------
+
+   function Enum_Format
+     (Format : Formatted_String;
+      Var    : Enum) return Formatted_String is
+   begin
+      return Format & Enum'Image (Var);
+   end Enum_Format;
+
+   --------------
+   -- Finalize --
+   --------------
+
+   overriding procedure Finalize (F : in out Formatted_String) is
+
+      procedure Unchecked_Free is
+        new Unchecked_Deallocation (Data, Data_Access);
+
+      D : Data_Access := F.D;
+   begin
+      F.D := null;
+
+      D.Ref_Count := D.Ref_Count - 1;
+
+      if D.Ref_Count = 0 then
+         Unchecked_Free (D);
+      end if;
+   end Finalize;
+
+   ------------------
+   -- Fixed_Format --
+   ------------------
+
+   function Fixed_Format
+     (Format : Formatted_String;
+      Var    : Flt) return Formatted_String
+   is
+      function Flt_Format is new P_Flt_Format (Flt, Put);
+   begin
+      return Flt_Format (Format, Var);
+   end Fixed_Format;
+
+   ----------------
+   -- Flt_Format --
+   ----------------
+
+   function Flt_Format
+     (Format : Formatted_String;
+      Var    : Flt) return Formatted_String
+   is
+      function Flt_Format is new P_Flt_Format (Flt, Put);
+   begin
+      return Flt_Format (Format, Var);
+   end Flt_Format;
+
+   -------------------
+   -- Get_Formatted --
+   -------------------
+
+   function Get_Formatted
+     (F_Spec : F_Data;
+      Value  : String;
+      Len    : Positive) return String
+   is
+      use Ada.Strings.Fixed;
+
+      Res : Unbounded_String;
+      S   : Positive := Value'First;
+   begin
+      --  Let's hanfles the flags
+
+      if F_Spec.Kind in Is_Number then
+         if F_Spec.Sign = Forced and then Value (Value'First) /= '-' then
+            Append (Res, "+");
+         elsif F_Spec.Sign = Space and then Value (Value'First) /= '-' then
+            Append (Res, " ");
+         end if;
+
+         if Value (Value'First) = '-' then
+            Append (Res, "-");
+            S := S + 1;
+         end if;
+      end if;
+
+      --  Zero padding if required and possible
+
+      if F_Spec.Left_Justify = False
+        and then F_Spec.Zero_Pad
+        and then F_Spec.Width > Len + Value'First - S
+      then
+         Append (Res, String'((F_Spec.Width - Len + Value'First - S) * '0'));
+      end if;
+
+      --  Add the value now
+
+      Append (Res, Value (S .. Value'Last));
+
+      declare
+         R : String (1 .. Natural'Max (Natural'Max (F_Spec.Width, Len),
+                                       Length (Res))) := (others => ' ');
+      begin
+         if F_Spec.Left_Justify then
+            R (1 .. Length (Res)) := To_String (Res);
+         else
+            R (R'Last - Length (Res) + 1 .. R'Last) := To_String (Res);
+         end if;
+
+         return R;
+      end;
+   end Get_Formatted;
+
+   ----------------
+   -- Int_Format --
+   ----------------
+
+   function Int_Format
+     (Format : Formatted_String;
+      Var    : Int) return Formatted_String
+   is
+      function Sign (Var : Int) return Sign_Kind
+      is (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
+      function To_Integer (Var : Int) return Integer is (Integer (Var));
+      function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
+   begin
+      return Int_Format (Format, Var);
+   end Int_Format;
+
+   ----------------
+   -- Mod_Format --
+   ----------------
+
+   function Mod_Format
+     (Format : Formatted_String;
+      Var    : Int) return Formatted_String
+   is
+      function Sign (Var : Int) return Sign_Kind
+        is (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
+      function To_Integer (Var : Int) return Integer is (Integer (Var));
+      function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
+   begin
+      return Int_Format (Format, Var);
+   end Mod_Format;
+
+   -----------------
+   -- Next_Format --
+   -----------------
+
+   procedure Next_Format
+     (Format : Formatted_String;
+      F_Spec : out F_Data;
+      Start  : out Positive)
+   is
+      F              : String renames Format.D.Format;
+      I              : Natural renames Format.D.Index;
+      S              : Natural;
+      Width_From_Var : Boolean := False;
+   begin
+      Format.D.Current := Format.D.Current + 1;
+      F_Spec.Value_Needed := 0;
+
+      --  Got to next %
+
+      while (I <= F'Last and then F (I) /= '%')
+        or else (I < F'Last - 1 and then F (I + 1) = '%')
+      loop
+         Append (Format.D.Result, F (I));
+
+         --  If we have two consecutive %, skip the second one
+
+         if F (I) = '%' and then I < F'Last - 1 and then F (I + 1) = '%' then
+            I := I + 1;
+         end if;
+
+         I := I + 1;
+      end loop;
+
+      if F (I) /= '%' or else I = F'Last then
+         raise Format_Error with "no format specifier found for parameter"
+           & Positive'Image (Format.D.Current);
+      end if;
+
+      Start := I;
+
+      I := I + 1;
+
+      --  Check for any flags
+
+      Flags_Check : while I < F'Last loop
+         if F (I) = '-' then
+            F_Spec.Left_Justify := True;
+         elsif F (I) = '+' then
+            F_Spec.Sign := Forced;
+         elsif F (I) = ' ' then
+            F_Spec.Sign := Space;
+         elsif F (I) = '#' then
+            F_Spec.Base := C_Style;
+         elsif F (I) = '~' then
+            F_Spec.Base := Ada_Style;
+         elsif F (I) = '0' then
+            F_Spec.Zero_Pad := True;
+         else
+            exit Flags_Check;
+         end if;
+
+         I := I + 1;
+      end loop Flags_Check;
+
+      --  Check width if any
+
+      if F (I) in '0' .. '9' then
+         --  We have a width parameter
+
+         S := I;
+
+         while I < F'Last and then F (I + 1) in '0' .. '9' loop
+            I := I + 1;
+         end loop;
+
+         F_Spec.Width := Natural'Value (F (S .. I));
+
+         I := I + 1;
+
+      elsif F (I) = '*' then
+         --  The width will be taken from the integer parameter
+
+         F_Spec.Value_Needed := 1;
+         Width_From_Var := True;
+
+         I := I + 1;
+      end if;
+
+      if F (I) = '.' then
+         --  We have a precision parameter
+
+         I := I + 1;
+
+         if F (I) in '0' .. '9' then
+            S := I;
+
+            while I < F'Length and then F (I + 1) in '0' .. '9' loop
+               I := I + 1;
+            end loop;
+
+            if F (I) = '.' then
+               --  No precision, 0 is assumed
+               F_Spec.Precision := 0;
+            else
+               F_Spec.Precision := Natural'Value (F (S .. I));
+            end if;
+
+            I := I + 1;
+
+         elsif F (I) = '*' then
+            --  The prevision will be taken from the integer parameter
+
+            F_Spec.Value_Needed := F_Spec.Value_Needed + 1;
+            I := I + 1;
+         end if;
+      end if;
+
+      --  Skip the length specifier, this is not needed for this implementation
+      --  but yet for compatibility reason it is handled.
+
+      Length_Check :
+      while I <= F'Last
+        and then F (I) in 'h' | 'l' | 'j' | 'z' | 't' | 'L'
+      loop
+         I := I + 1;
+      end loop Length_Check;
+
+      if I > F'Last then
+         Raise_Wrong_Format (Format);
+      end if;
+
+      --  Read next character which should be the expected type
+
+      case F (I) is
+         when 'c'       => F_Spec.Kind := Char;
+         when 's'       => F_Spec.Kind := Str;
+         when 'd' | 'i' => F_Spec.Kind := Decimal_Int;
+         when 'u'       => F_Spec.Kind := Unsigned_Decimal_Int;
+         when 'f' | 'F' => F_Spec.Kind := Decimal_Float;
+         when 'e'       => F_Spec.Kind := Decimal_Scientific_Float;
+         when 'E'       => F_Spec.Kind := Decimal_Scientific_Float_Up;
+         when 'g'       => F_Spec.Kind := Shortest_Decimal_Float;
+         when 'G'       => F_Spec.Kind := Shortest_Decimal_Float_Up;
+         when 'o'       => F_Spec.Kind := Unsigned_Octal;
+         when 'x'       => F_Spec.Kind := Unsigned_Hexadecimal_Int;
+         when 'X'       => F_Spec.Kind := Unsigned_Hexadecimal_Int_Up;
+
+         when others =>
+            raise Format_Error with "unknown format specified for parameter"
+              & Positive'Image (Format.D.Current);
+      end case;
+
+      I := I + 1;
+
+      if F_Spec.Value_Needed > 0
+        and then F_Spec.Value_Needed = Format.D.Stored_Value
+      then
+         if F_Spec.Value_Needed = 1 then
+            if Width_From_Var then
+               F_Spec.Width := Format.D.Stack (1);
+            else
+               F_Spec.Precision := Format.D.Stack (1);
+            end if;
+
+         else
+            F_Spec.Width := Format.D.Stack (1);
+            F_Spec.Precision := Format.D.Stack (2);
+         end if;
+      end if;
+   end Next_Format;
+
+   ------------------
+   -- P_Flt_Format --
+   ------------------
+
+   function P_Flt_Format
+     (Format : Formatted_String;
+      Var    : Flt) return Formatted_String
+   is
+      F      : F_Data;
+      Buffer : String (1 .. 50);
+      S, E   : Positive := 1;
+      Start  : Positive;
+      Aft    : Text_IO.Field;
+   begin
+      Next_Format (Format, F, Start);
+
+      if F.Value_Needed > 0 then
+         Raise_Wrong_Format (Format);
+      end if;
+
+      if F.Precision = Unset then
+         Aft := 6;
+      else
+         Aft := F.Precision;
+      end if;
+
+      case F.Kind is
+         when Decimal_Float =>
+
+            Put (Buffer, Var, Aft, Exp => 0);
+            S := Strings.Fixed.Index_Non_Blank (Buffer);
+            E := Buffer'Last;
+
+         when Decimal_Scientific_Float | Decimal_Scientific_Float_Up =>
+
+            Put (Buffer, Var, Aft, Exp => 3);
+            S := Strings.Fixed.Index_Non_Blank (Buffer);
+            E := Buffer'Last;
+
+            if F.Kind = Decimal_Scientific_Float then
+               Buffer (S .. E) :=
+                 Characters.Handling.To_Lower (Buffer (S .. E));
+            end if;
+
+         when Shortest_Decimal_Float | Shortest_Decimal_Float_Up =>
+            --  Without exponent
+
+            Put (Buffer, Var, Aft, Exp => 0);
+            S := Strings.Fixed.Index_Non_Blank (Buffer);
+            E := Buffer'Last;
+
+            --  Check with exponent
+
+            declare
+               Buffer2 : String (1 .. 50);
+               S2, E2  : Positive;
+            begin
+               Put (Buffer2, Var, Aft, Exp => 3);
+               S2 := Strings.Fixed.Index_Non_Blank (Buffer2);
+               E2 := Buffer2'Last;
+
+               --  If with exponent it is shorter, use it
+
+               if (E2 - S2) < (E - S) then
+                  Buffer := Buffer2;
+                  S := S2;
+                  E := E2;
+               end if;
+            end;
+
+            if F.Kind = Shortest_Decimal_Float then
+               Buffer (S .. E) :=
+                 Characters.Handling.To_Lower (Buffer (S .. E));
+            end if;
+
+         when others =>
+            Raise_Wrong_Format (Format);
+      end case;
+
+      Append (Format.D.Result,
+              Get_Formatted (F, Buffer (S .. E), Buffer (S .. E)'Length));
+
+      return Format;
+   end P_Flt_Format;
+
+   ------------------
+   -- P_Int_Format --
+   ------------------
+
+   function P_Int_Format
+     (Format : Formatted_String;
+      Var    : Int) return Formatted_String
+   is
+
+      function Handle_Precision return Boolean;
+      --  Return True if nothing else to do
+
+      F      : F_Data;
+      Buffer : String (1 .. 50);
+      S, E   : Positive := 1;
+      Len    : Natural := 0;
+      Start  : Positive;
+
+      ----------------------
+      -- Handle_Precision --
+      ----------------------
+
+      function Handle_Precision return Boolean is
+      begin
+         if F.Precision = 0 and then Sign (Var) = Zero then
+            return True;
+
+         elsif F.Precision = Natural'Last then
+            null;
+
+         elsif F.Precision > E - S + 1 then
+            Len := F.Precision - (E - S + 1);
+            Buffer (S - Len .. S - 1) := (others => '0');
+            S := S - Len;
+         end if;
+
+         return False;
+      end Handle_Precision;
+
+   begin
+      Next_Format (Format, F, Start);
+
+      if Format.D.Stored_Value < F.Value_Needed then
+         Format.D.Stored_Value := Format.D.Stored_Value + 1;
+         Format.D.Stack (Format.D.Stored_Value) := To_Integer (Var);
+         Format.D.Index := Start;
+         return Format;
+      end if;
+
+      case F.Kind is
+         when Unsigned_Octal =>
+            if Sign (Var) = Neg then
+               Raise_Wrong_Format (Format);
+            end if;
+
+            Put (Buffer, Var, Base => 8);
+            S := Strings.Fixed.Index (Buffer, "8#") + 2;
+            E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
+
+            if Handle_Precision then
+               return Format;
+            end if;
+
+            case F.Base is
+               when None      => null;
+               when C_Style   => Len := 1;
+               when Ada_Style => Len := 3;
+            end case;
+
+         when Unsigned_Hexadecimal_Int =>
+            if Sign (Var) = Neg then
+               Raise_Wrong_Format (Format);
+            end if;
+
+            Put (Buffer, Var, Base => 16);
+            S := Strings.Fixed.Index (Buffer, "16#") + 3;
+            E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
+            Buffer (S .. E) := Characters.Handling.To_Lower (Buffer (S .. E));
+
+            if Handle_Precision then
+               return Format;
+            end if;
+
+            case F.Base is
+               when None      => null;
+               when C_Style   => Len := 2;
+               when Ada_Style => Len := 4;
+            end case;
+
+         when Unsigned_Hexadecimal_Int_Up =>
+            if Sign (Var) = Neg then
+               Raise_Wrong_Format (Format);
+            end if;
+
+            Put (Buffer, Var, Base => 16);
+            S := Strings.Fixed.Index (Buffer, "16#") + 3;
+            E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
+
+            if Handle_Precision then
+               return Format;
+            end if;
+
+            case F.Base is
+               when None      => null;
+               when C_Style   => Len := 2;
+               when Ada_Style => Len := 4;
+            end case;
+
+         when Unsigned_Decimal_Int =>
+            if Sign (Var) = Neg then
+               Raise_Wrong_Format (Format);
+            end if;
+
+            Put (Buffer, Var, Base => 10);
+            S := Strings.Fixed.Index_Non_Blank (Buffer);
+            E := Buffer'Last;
+
+            if Handle_Precision then
+               return Format;
+            end if;
+
+         when Decimal_Int =>
+            Put (Buffer, Var, Base => 10);
+            S := Strings.Fixed.Index_Non_Blank (Buffer);
+            E := Buffer'Last;
+
+            if Handle_Precision then
+               return Format;
+            end if;
+
+         when Char =>
+            S := Buffer'First;
+            E := Buffer'First;
+            Buffer (S) := Character'Val (To_Integer (Var));
+
+            if Handle_Precision then
+               return Format;
+            end if;
+
+         when others =>
+            Raise_Wrong_Format (Format);
+      end case;
+
+      --  Then add base if needed
+
+      declare
+         N : String :=
+               Get_Formatted (F, Buffer (S .. E), E - S + 1 + Len);
+         P : constant Positive :=
+               (if F.Left_Justify
+                then N'First
+                else Natural'Max (Strings.Fixed.Index_Non_Blank (N) - 1,
+                                  N'First));
+      begin
+         case F.Base is
+            when None   =>
+               null;
+
+            when C_Style   =>
+               case F.Kind is
+                  when Unsigned_Octal =>
+                     N (P) := 'O';
+
+                  when Unsigned_Hexadecimal_Int =>
+                     if F.Left_Justify then
+                        N (P .. P + 1) := "Ox";
+                     else
+                        N (P - 1 .. P) := "0x";
+                     end if;
+
+                  when Unsigned_Hexadecimal_Int_Up =>
+                     if F.Left_Justify then
+                        N (P .. P + 1) := "OX";
+                     else
+                        N (P - 1 .. P) := "0X";
+                     end if;
+
+                  when others =>
+                     null;
+               end case;
+
+            when Ada_Style   =>
+               case F.Kind is
+                  when Unsigned_Octal =>
+                     if F.Left_Justify then
+                        N (N'First + 2 .. N'Last) := N (N'First .. N'Last - 2);
+                     else
+                        N (P .. N'Last - 1) := N (P + 1 .. N'Last);
+                     end if;
+
+                     N (N'First .. N'First + 1) := "8#";
+                     N (N'Last) := '#';
+
+                  when Unsigned_Hexadecimal_Int
+                    | Unsigned_Hexadecimal_Int_Up
+                    =>
+                     if F.Left_Justify then
+                        N (N'First + 3 .. N'Last) := N (N'First .. N'Last - 3);
+                     else
+                        N (P .. N'Last - 1) := N (P + 1 .. N'Last);
+                     end if;
+
+                     N (N'First .. N'First + 2) := "16#";
+                     N (N'Last) := '#';
+
+                  when others =>
+                     null;
+               end case;
+         end case;
+
+         Append (Format.D.Result, N);
+      end;
+
+      return Format;
+   end P_Int_Format;
+
+   ------------------------
+   -- Raise_Wrong_Format --
+   ------------------------
+
+   procedure Raise_Wrong_Format (Format : Formatted_String) is
+   begin
+      raise Format_Error with "wrong format specified for parameter"
+        & Positive'Image (Format.D.Current);
+   end Raise_Wrong_Format;
+
+end GNAT.Formatted_String;

gcc/ada/g-forstr.ads

@@ -0,0 +1,285 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                G N A T . F O R M A T T E D _ S T R I N G                 --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--             Copyright (C) 2014, 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- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package add support for formatted string as supported by C printf().
+--
+--  A simple usage is:
+--
+--     declare
+--        F : Formatted_String := +"['%c' ; %10d]";
+--        C : Character := 'v';
+--        I : Integer := 98;
+--     begin
+--        F := F & C & I;
+--        Put_Line (-F);
+--
+--     end;
+--
+--  Which will display:
+--
+--     ['v' ;         98]
+--
+--
+--  Each format specifier is: %[flags][width][.precision][length]specifier
+--
+--  Specifiers:
+--    d or i    Signed decimal integer
+--    u         Unsigned decimal integer
+--    o         Unsigned octal
+--    x         Unsigned hexadecimal integer
+--    X         Unsigned hexadecimal integer (uppercase)
+--    f         Decimal floating point, lowercase
+--    F         Decimal floating point, uppercase
+--    e         Scientific notation (mantissa/exponent), lowercase
+--    E         Scientific notation (mantissa/exponent), uppercase
+--    g         Use the shortest representation: %e or %f
+--    G         Use the shortest representation: %E or %F
+--    c         Character
+--    s         String of characters
+--    p         Pointer address
+--    %         A % followed by another % character will write a single %
+--
+--  Flags:
+--    -         Left-justify within the given field width;
+--              Right justification is the default
+--    +         Forces to preceed the result with a plus or minus sign (+ or -)
+--              even for positive numbers. By default, only negative numbers
+--              are preceded with a - sign.
+--    (space)   If no sign is going to be written, a blank space is inserted
+--              before the value.
+--    #         Used with o, x or X specifiers the value is preceeded with
+--              0, 0x or 0X respectively for values different than zero.
+--              Used with a, A, e, E, f, F, g or G it forces the written
+--              output to contain a decimal point even if no more digits
+--              follow. By default, if no digits follow, no decimal point is
+--              written.
+--    ~         As above, but using Ada style based <base>#<number>#
+--    0         Left-pads the number with zeroes (0) instead of spaces when
+--              padding is specified.
+--  Width:
+--    number    Minimum number of characters to be printed. If the value to
+--              be printed is shorter than this number, the result is padded
+--              with blank spaces. The value is not truncated even if the
+--              result is larger.
+--    *         The width is not specified in the format string, but as an
+--              additional integer value argument preceding the argument that
+--              has to be formatted.
+--  Precision:
+--    number    For integer specifiers (d, i, o, u, x, X): precision specifies
+--              the minimum number of digits to be written. If the value to be
+--              written is shorter than this number, the result is padded with
+--              leading zeros. The value is not truncated even if the result
+--              is longer. A precision of 0 means that no character is written
+--              for the value 0.
+--              For e, E, f and F specifiers: this is the number of digits to
+--              be printed after the decimal point (by default, this is 6).
+--              For g and G specifiers: This is the maximum number of
+--              significant digits to be printed.
+--              For s: this is the maximum number of characters to be printed.
+--              By default all characters are printed until the ending null
+--              character is encountered.
+--              If the period is specified without an explicit value for
+--              precision, 0 is assumed.
+--    .*        The precision is not specified in the format string, but as an
+--              additional integer value argument preceding the argument that
+--              has to be formatted.
+
+with Ada.Text_IO;
+with System;
+
+private with Ada.Finalization;
+private with Ada.Strings.Unbounded;
+
+package GNAT.Formatted_String is
+
+   use Ada;
+
+   type Formatted_String (<>) is private;
+   --  A format string as defined for printf routine
+
+   Format_Error : exception;
+   --  Raised for every mismatch between the parameter and the expected format
+   --  and for malformed format.
+
+   function "+" (Format : String) return Formatted_String;
+   --  Create the format string
+
+   function "-" (Format : Formatted_String) return String;
+   --  Get the result of the formatted string corresponding to the current
+   --  rendering (up to the last parameter formated).
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Character) return Formatted_String;
+   --  A character, expect a %c
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : String) return Formatted_String;
+   --  A string, expect a %s
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Boolean) return Formatted_String;
+   --  A boolean image, expect a %s
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Integer) return Formatted_String;
+   --  An integer, expect a %d, %o, %x, %X
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Long_Integer) return Formatted_String;
+   --  As above
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : System.Address) return Formatted_String;
+   --  An address, expect a %p
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Float) return Formatted_String;
+   --  A float, expect %f, %e, %F, %E, %g, %G
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Long_Float) return Formatted_String;
+   --  As above
+
+   function "&"
+     (Format : Formatted_String;
+      Var    : Duration) return Formatted_String;
+   --  As above
+
+   --  Some generics
+
+   generic
+      type Int is range <>;
+
+      with procedure Put
+        (To   : out String;
+         Item : Int;
+         Base : Text_IO.Number_Base);
+   function Int_Format
+     (Format : Formatted_String;
+      Var    : Int) return Formatted_String;
+   --  As for Integer above
+
+   generic
+      type Int is mod <>;
+
+      with procedure Put
+        (To   : out String;
+         Item : Int;
+         Base : Text_IO.Number_Base);
+   function Mod_Format
+     (Format : Formatted_String;
+      Var    : Int) return Formatted_String;
+   --  As for Integer above
+
+   generic
+      type Flt is digits <>;
+
+      with procedure Put
+        (To   : out String;
+         Item : Flt;
+         Aft  : Text_IO.Field;
+         Exp  : Text_IO.Field);
+   function Flt_Format
+     (Format : Formatted_String;
+      Var    : Flt) return Formatted_String;
+   --  As for Float above
+
+   generic
+      type Flt is delta <>;
+
+      with procedure Put
+        (To   : out String;
+         Item : Flt;
+         Aft  : Text_IO.Field;
+         Exp  : Text_IO.Field);
+   function Fixed_Format
+     (Format : Formatted_String;
+      Var    : Flt) return Formatted_String;
+   --  As for Float above
+
+   generic
+      type Flt is delta <> digits <>;
+
+      with procedure Put
+        (To   : out String;
+         Item : Flt;
+         Aft  : Text_IO.Field;
+         Exp  : Text_IO.Field);
+   function Decimal_Format
+     (Format : Formatted_String;
+      Var    : Flt) return Formatted_String;
+   --  As for Float above
+
+   generic
+      type Enum is (<>);
+   function Enum_Format
+     (Format : Formatted_String; Var : Enum) return Formatted_String;
+   --  As for String above, output the string representation of the enumeration
+
+private
+
+   use Ada.Strings.Unbounded;
+
+   type I_Vars is array (Positive range 1 .. 2) of Integer;
+   --  Used to keep 2 numbers for the possible * for the width and precision
+
+   type Data (Size : Natural) is record
+      Ref_Count    : Natural := 1;
+      Format       : String (1 .. Size); -- the format string
+      Index        : Positive := 1;      -- format index for next value
+      Result       : Unbounded_String;   -- current value
+      Current      : Natural;            -- the current format number
+      Stored_Value : Natural := 0;       -- number of stored values in Stack
+      Stack        : I_Vars;
+   end record;
+
+   type Data_Access is access Data;
+
+   --  The formatted string record is controlled and do not need an initialize
+   --  as it requires an explit initial value. This is given with "+" and
+   --  properly initialize the record at this point.
+
+   type Formatted_String is new Finalization.Controlled with record
+      D : Data_Access;
+   end record;
+
+   overriding procedure Adjust   (F : in out Formatted_String);
+   overriding procedure Finalize (F : in out Formatted_String);
+
+end GNAT.Formatted_String;

gcc/ada/gnat_rm.texi

@@ -594,6 +594,7 @@ The GNAT Library
 * GNAT.Expect (g-expect.ads)::
 * GNAT.Expect.TTY (g-exptty.ads)::
 * GNAT.Float_Control (g-flocon.ads)::
+* GNAT.Formatted_String (g-forstr.ads)::
 * GNAT.Heap_Sort (g-heasor.ads)::
 * GNAT.Heap_Sort_A (g-hesora.ads)::
 * GNAT.Heap_Sort_G (g-hesorg.ads)::
@@ -18934,6 +18935,7 @@ of GNAT, and will generate a warning message.
 * GNAT.Expect (g-expect.ads)::
 * GNAT.Expect.TTY (g-exptty.ads)::
 * GNAT.Float_Control (g-flocon.ads)::
+* GNAT.Formatted_String (g-forstr.ads)::
 * GNAT.Heap_Sort (g-heasor.ads)::
 * GNAT.Heap_Sort_A (g-hesora.ads)::
 * GNAT.Heap_Sort_G (g-hesorg.ads)::
@@ -19860,6 +19862,18 @@ mode required for correct semantic operation in Ada.  Some third party
 library calls may cause this mode to be modified, and the Reset procedure
 in this package can be used to reestablish the required mode.
 
+@node GNAT.Formatted_String (g-forstr.ads)
+@section @code{GNAT.Formatted_String} (@file{g-forstr.ads})
+@cindex @code{GNAT.Formatted_String} (@file{g-forstr.ads})
+@cindex Formatted String
+
+@noindent
+Provides support for C/C++ printf() formatted string. The format is
+copied from the printf() routine and should therefore gives identical
+output. Some generic routines are provided to be able to use types
+derived from Integer, Float or enumerations as values for the
+formatted string.
+
 @node GNAT.Heap_Sort (g-heasor.ads)
 @section @code{GNAT.Heap_Sort} (@file{g-heasor.ads})
 @cindex @code{GNAT.Heap_Sort} (@file{g-heasor.ads})

gcc/ada/gnat_ugn.texi

@@ -19436,10 +19436,11 @@ For full details, refer to @cite{GNATcheck Reference Manual} document.
 @findex gnatstub
 
 @noindent
-@command{gnatstub} creates body stubs, that is, empty but compilable bodies
+@command{gnatstub} creates empty but compilable bodies
-for library unit declarations.
+for library unit declarations and empty but compilable
+subunit for body stubs.
 
-To create a body stub, @command{gnatstub} invokes the Ada
+To create a body or a subunit, @command{gnatstub} invokes the Ada
 compiler and generates and uses the ASIS tree for the input source;
 thus the input must be legal Ada code, and the tool should have all the
 information needed to compile the input source. To provide this information,
@@ -19455,7 +19456,7 @@ then the needed options should be provided to run preprocessor as a part of
 the @command{gnatstub} call, and the generated body stub will correspond to
 the preprocessed source.
 
-By default, all the program unit body stubs generated by @code{gnatstub}
+By default, all the program unit bodies generated by @code{gnatstub}
 raise the predefined @code{Program_Error} exception, which will catch
 accidental calls of generated stubs. This behavior can be changed with
 option @option{^--no-exception^/NO_EXCEPTION^} (see below).
@@ -19472,9 +19473,9 @@ option @option{^--no-exception^/NO_EXCEPTION^} (see below).
 @command{gnatstub} has a command-line interface of the form:
 
 @smallexample
-@c $ gnatstub @ovar{switches} @var{filename} @ovar{directory}
+@c $ gnatstub @ovar{switches} @var{filename}
 @c Expanding @ovar macro inline (explanation in macro def comments)
-$ gnatstub @r{[}@var{switches}@r{]} @var{filename} @r{[}@var{directory}@r{]} @r{[}-cargs @var{gcc_switches}@r{]}
+$ gnatstub @r{[}@var{switches}@r{]} @var{filename} @r{[}-cargs @var{gcc_switches}@r{]}
 @end smallexample
 
 @noindent
@@ -19482,25 +19483,21 @@ where
 @table @var
 @item filename
 is the name of the source file that contains a library unit declaration
-for which a body must be created. The file name may contain the path
+for which a body must be created or a library unit body for which subunits
-information.
+must be created for the body stubs declared in this body.
-The file name does not have to follow the GNAT file name conventions. If the
+The file name may contain the path information.
-name
+If the name does not follow GNAT file naming conventions and a set
-does not follow GNAT file naming conventions, the name of the body file must
+of seitches does not contain a project file that defines naming
+conventions, the name of the body file must
 be provided
 explicitly as the value of the @option{^-o^/BODY=^@var{body-name}} option.
 If the file name follows the GNAT file naming
 conventions and the name of the body file is not provided,
 @command{gnatstub}
-creates the name
+takes the naming conventions for the generated source from the
-of the body file from the argument file name by replacing the @file{.ads}
+project file provided as a parameter of @option{-P} switch if any,
-suffix
+or creates the name file to generate using the standard GNAT
-with the @file{.adb} suffix.
+naming conventions.
-
-@item directory
-indicates the directory in which the body stub is to be placed (the default
-is the
-current directory)
 
 @item @samp{@var{gcc_switches}} is a list of switches for
 @command{gcc}. They will be passed on to all compiler invocations made by
@@ -19539,11 +19536,20 @@ Indicates that external variable @var{name} in the argument project
 has the value @var{value}. Has no effect if no project is specified as
 tool argument.
 
+@item ^--subunits^/SUBUNITS^
+@cindex @option{^--subunits^/SUBUNITS^} (@command{gnatstub})
+Generate subunits for body stubs. If this switch is specified,
+@command{gnatstub} expects a library unit body as an agrument file,
+otherwise a library unit declaration is expected. If a body stub
+already has a corresponding subunit, @command{gnatstub} does not
+generate anything for it.
+
 @item ^-f^/FULL^
 @cindex @option{^-f^/FULL^} (@command{gnatstub})
 If the destination directory already contains a file with the name of the
 body file
 for the argument spec file, replace it with the generated body stub.
+This switch cannot be used together with @option{^--subunits^/SUBUNITS^}.
 
 @item ^-hs^/HEADER=SPEC^
 @cindex @option{^-hs^/HEADER=SPEC^} (@command{gnatstub})
@@ -19633,6 +19639,13 @@ conventions. If this switch is omitted the default name for the body will be
 obtained
 from the argument file name according to the GNAT file naming conventions.
 
+@item ^--dir=^/DIR=^@var{dir-name}
+@cindex @option{^--dir^/DIR^} (@command{gnatstub})
+The path to the directory to place the generated files into.
+If this switch is not set, the generated library unit body is
+placed in the current directory, and generated sununits -
+in the directory where the argument body is located.
+
 @item ^-W^/RESULT_ENCODING=^@var{e}
 @cindex @option{^-W^/RESULT_ENCODING=^} (@command{gnatstub})
 Specify the wide character encoding method for the output body file.

gcc/ada/impunit.adb

@@ -273,6 +273,7 @@ package body Impunit is
     ("g-expect", F),  -- GNAT.Expect
     ("g-exptty", F),  -- GNAT.Expect.TTY
     ("g-flocon", F),  -- GNAT.Float_Control
+    ("g-forstr", F),  -- GNAT.Formatted_String
     ("g-heasor", F),  -- GNAT.Heap_Sort
     ("g-hesora", F),  -- GNAT.Heap_Sort_A
     ("g-hesorg", F),  -- GNAT.Heap_Sort_G

gcc/ada/sem_ch13.adb

@@ -2905,10 +2905,46 @@ package body Sem_Ch13 is
                      goto Continue;
                   end if;
 
+                  --  External property aspects are Boolean by nature, but
+                  --  their pragmas must contain two arguments, the second
+                  --  being the optional Boolean expression.
+
+                  if A_Id = Aspect_Async_Readers
+                    or else A_Id = Aspect_Async_Writers
+                    or else A_Id = Aspect_Effective_Reads
+                    or else A_Id = Aspect_Effective_Writes
+                  then
+                     declare
+                        Args : List_Id;
+
+                     begin
+                        --  The first argument of the external property pragma
+                        --  is the related object.
+
+                        Args := New_List (
+                          Make_Pragma_Argument_Association (Sloc (Ent),
+                            Expression => Ent));
+
+                        --  The second argument is the optional Boolean
+                        --  expression which must be propagated even if it
+                        --  evaluates to False as this has special semantic
+                        --  meaning.
+
+                        if Present (Expr) then
+                           Append_To (Args,
+                             Make_Pragma_Argument_Association (Loc,
+                               Expression => Relocate_Node (Expr)));
+                        end if;
+
+                        Make_Aitem_Pragma
+                          (Pragma_Argument_Associations => Args,
+                           Pragma_Name                  => Nam);
+                     end;
+
                   --  Cases where we do not delay, includes all cases where
                   --  the expression is missing other than the above cases.
 
-                  if not Delay_Required or else No (Expr) then
+                  elsif not Delay_Required or else No (Expr) then
                      Make_Aitem_Pragma
                        (Pragma_Argument_Associations => New_List (
                           Make_Pragma_Argument_Association (Sloc (Ent),
@@ -2918,7 +2954,7 @@ package body Sem_Ch13 is
 
                   --  In general cases, the corresponding pragma/attribute
                   --  definition clause will be inserted later at the freezing
-                  --  point, and we do not need to build it now
+                  --  point, and we do not need to build it now.
 
                   else
                      Aitem := Empty;

gcc/ada/sem_prag.adb

@@ -1834,29 +1834,28 @@ package body Sem_Prag is
      (N        : Node_Id;
       Expr_Val : out Boolean)
    is
-      Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
+      Arg1   : constant Node_Id   := First (Pragma_Argument_Associations (N));
-      Obj  : constant Node_Id := Get_Pragma_Arg (Arg1);
+      Obj_Id : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
-      Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1));
+      Expr   : constant Node_Id   := Get_Pragma_Arg (Next (Arg1));
 
    begin
       Error_Msg_Name_1 := Pragma_Name (N);
 
-      --  The Async / Effective pragmas must apply to a volatile object other
+      --  An external property pragma must apply to a volatile object other
-      --  than a formal subprogram parameter (SPARK RM 7.1.3(2)).
+      --  than a formal subprogram parameter (SPARK RM 7.1.3(2)). The check
+      --  is performed at the end of the declarative region due to a possible
+      --  out-of-order arrangement of pragmas:
+      --
+      --    Obj : ...;
+      --    pragma Async_Readers (Obj);
+      --    pragma Volatile (Obj);
 
-      if Is_SPARK_Volatile_Object (Obj) then
+      if not Is_SPARK_Volatile (Obj_Id) then
-         if Is_Entity_Name (Obj)
-           and then Present (Entity (Obj))
-           and then Is_Formal (Entity (Obj))
-         then
-            SPARK_Msg_N ("external property % cannot apply to parameter", N);
-         end if;
-      else
          SPARK_Msg_N
            ("external property % must apply to a volatile object", N);
       end if;
 
-      --  Ensure that the expression (if present) is static Boolean. A missing
+      --  Ensure that the Boolean expression (if present) is static. A missing
       --  argument defaults the value to True (SPARK RM 7.1.2(5)).
 
       Expr_Val := True;
@@ -1867,7 +1866,6 @@ package body Sem_Prag is
          if Is_OK_Static_Expression (Expr) then
             Expr_Val := Is_True (Expr_Value (Expr));
          else
-            Error_Msg_Name_1 := Pragma_Name (N);
             SPARK_Msg_N ("expression of % must be static", Expr);
          end if;
       end if;
@@ -11581,6 +11579,8 @@ package body Sem_Prag is
               Pragma_Effective_Writes =>
          Async_Effective : declare
             Duplic : Node_Id;
+            Expr   : Node_Id;
+            Obj    : Node_Id;
             Obj_Id : Entity_Id;
 
          begin
@@ -11589,48 +11589,47 @@ package body Sem_Prag is
             Check_At_Least_N_Arguments (1);
             Check_At_Most_N_Arguments  (2);
             Check_Arg_Is_Local_Name (Arg1);
+            Error_Msg_Name_1 := Pname;
 
-            Arg1 := Get_Pragma_Arg (Arg1);
+            Obj  := Get_Pragma_Arg (Arg1);
+            Expr := Get_Pragma_Arg (Arg2);
 
             --  Perform minimal verification to ensure that the argument is at
             --  least a variable. Subsequent finer grained checks will be done
             --  at the end of the declarative region the contains the pragma.
 
-            if Is_Entity_Name (Arg1) and then Present (Entity (Arg1)) then
+            if Is_Entity_Name (Obj)
-               Obj_Id := Entity (Get_Pragma_Arg (Arg1));
+              and then Present (Entity (Obj))
+              and then Ekind (Entity (Obj)) = E_Variable
+            then
+               Obj_Id := Entity (Obj);
 
-               --  It is not efficient to examine preceding statements in order
+               --  Detect a duplicate pragma. Note that it is not efficient to
-               --  to detect duplicate pragmas as Boolean aspects may appear
+               --  examine preceding statements as Boolean aspects may appear
                --  anywhere between the related object declaration and its
                --  freeze point. As an alternative, inspect the contents of the
                --  variable contract.
 
-               if Ekind (Obj_Id) = E_Variable then
+               Duplic := Get_Pragma (Obj_Id, Prag_Id);
-                  Duplic := Get_Pragma (Obj_Id, Prag_Id);
 
-                  if Present (Duplic) then
+               if Present (Duplic) then
-                     Error_Msg_Name_1 := Pname;
+                  Error_Msg_Sloc := Sloc (Duplic);
-                     Error_Msg_Sloc   := Sloc (Duplic);
+                  Error_Msg_N ("pragma % duplicates pragma declared #", N);
-                     Error_Msg_N ("pragma % duplicates pragma declared #", N);
 
-                  --  Chain the pragma on the contract for further processing.
+               --  No duplicate detected
-                  --  This also aids in detecting duplicates.
 
-                  else
+               else
-                     Add_Contract_Item (N, Obj_Id);
+                  if Present (Expr) then
+                     Preanalyze_And_Resolve (Expr, Standard_Boolean);
                   end if;
 
-                  --  The minimum legality requirements have been met, do not
+                  --  Chain the pragma on the contract for further processing
-                  --  fall through to the error message.
 
-                  return;
+                  Add_Contract_Item (N, Obj_Id);
                end if;
+            else
+               Error_Pragma ("pragma % must apply to a volatile object");
             end if;
-
-            --  If we get here, then the pragma applies to a non-object
-            --  construct, issue a generic error (SPARK RM 7.1.3(2)).
-
-            Error_Pragma ("pragma % must apply to a volatile object");
          end Async_Effective;
 
          ------------------

gcc/ada/sem_util.adb

@@ -7423,10 +7423,11 @@ package body Sem_Util is
       Property : Name_Id) return Boolean
    is
       function State_Has_Enabled_Property return Boolean;
-      --  Determine whether a state denoted by Item_Id has the property
+      --  Determine whether a state denoted by Item_Id has the property enabled
 
       function Variable_Has_Enabled_Property return Boolean;
       --  Determine whether a variable denoted by Item_Id has the property
+      --  enabled.
 
       --------------------------------
       -- State_Has_Enabled_Property --
@@ -7528,6 +7529,44 @@ package body Sem_Util is
       -----------------------------------
 
       function Variable_Has_Enabled_Property return Boolean is
+         function Is_Enabled (Prag : Node_Id) return Boolean;
+         --  Determine whether property pragma Prag (if present) denotes an
+         --  enabled property.
+
+         ----------------
+         -- Is_Enabled --
+         ----------------
+
+         function Is_Enabled (Prag : Node_Id) return Boolean is
+            Arg2 : Node_Id;
+
+         begin
+            if Present (Prag) then
+               Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
+
+               --  The pragma has an optional Boolean expression, the related
+               --  property is enabled only when the expression evaluates to
+               --  True.
+
+               if Present (Arg2) then
+                  return Is_True (Expr_Value (Get_Pragma_Arg (Arg2)));
+
+               --  Otherwise the lack of expression enables the property by
+               --  default.
+
+               else
+                  return True;
+               end if;
+
+            --  The property was never set in the first place
+
+            else
+               return False;
+            end if;
+         end Is_Enabled;
+
+         --  Local variables
+
          AR : constant Node_Id :=
                 Get_Pragma (Item_Id, Pragma_Async_Readers);
          AW : constant Node_Id :=
@@ -7536,6 +7575,9 @@ package body Sem_Util is
                 Get_Pragma (Item_Id, Pragma_Effective_Reads);
          EW : constant Node_Id :=
                 Get_Pragma (Item_Id, Pragma_Effective_Writes);
+
+      --  Start of processing for Variable_Has_Enabled_Property
+
       begin
          --  A non-volatile object can never possess external properties
 
@@ -7544,33 +7586,25 @@ package body Sem_Util is
 
          --  External properties related to variables come in two flavors -
          --  explicit and implicit. The explicit case is characterized by the
-         --  presence of a property pragma while the implicit case lacks all
+         --  presence of a property pragma with an optional Boolean flag. The
-         --  such pragmas.
+         --  property is enabled when the flag evaluates to True or the flag is
+         --  missing altogether.
 
-         elsif Property = Name_Async_Readers
+         elsif Property = Name_Async_Readers and then Is_Enabled (AR) then
-           and then
-             (Present (AR)
-                or else
-             (No (AW) and then No (ER) and then No (EW)))
-         then
             return True;
 
-         elsif Property = Name_Async_Writers
+         elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
-           and then (Present (AW)
-                      or else (No (AR) and then No (ER) and then No (EW)))
-         then
             return True;
 
-         elsif Property = Name_Effective_Reads
+         elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then
-           and then (Present (ER)
-                      or else (No (AR) and then No (AW) and then No (EW)))
-         then
             return True;
 
-         elsif Property = Name_Effective_Writes
+         elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then
-           and then (Present (EW)
+            return True;
-                      or else (No (AR) and then No (AW) and then No (ER)))
+
-         then
+         --  The implicit case lacks all property pragmas
+
+         elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
             return True;
 
          else

gcc/ada/vms_data.ads

@@ -7167,6 +7167,16 @@ package VMS_Data is
    --
    --   Look for source, library or object files in the default directory.
 
+   S_Stub_Dir      : aliased constant S := "/DIR=@"                        &
+                                            "--dir=@";
+
+   --        /DIR=dirname
+   --
+   --   The directory to place the generated source(s) into. If this switch is
+   --   omitted, the generated library unit body is placed in the current
+   --   directory, and the generated subunit(s) - in the directory where the
+   --   argument body file is located.
+
    S_Stub_Encoding : aliased constant S := "/RESULT_ENCODING="             &
                                             "BRACKETS "                    &
                                                "-Wb "                      &
@@ -7352,6 +7362,16 @@ package VMS_Data is
    --   of the directory specified in the project file. If the subdirectory
    --   does not exist, it is created automatically.
 
+   S_Stub_Subunits : aliased constant S := "/SUBUNITS "                    &
+                                           "--subunits";
+
+   --        /NOSUBUNITS (D)
+   --        /SUBUNITS
+   --
+   --   Generate subunits for body stubs. If this switch is set, a library
+   --   unit body is expected as a tool argument, otherwise a library unit
+   --   declaration is expected to generate a body for.
+
    S_Stub_Tree    : aliased constant S := "/TREE_FILE="                    &
                                             "OVERWRITE "                   &
                                                "-t "                       &
@@ -7395,6 +7415,7 @@ package VMS_Data is
                      (S_Stub_Add        'Access,
                       S_Stub_Config     'Access,
                       S_Stub_Current    'Access,
+                      S_Stub_Dir        'Access,
                       S_Stub_Encoding   'Access,
                       S_Stub_Ext        'Access,
                       S_Stub_Follow     'Access,
@@ -7412,6 +7433,7 @@ package VMS_Data is
                       S_Stub_Quiet      'Access,
                       S_Stub_Search     'Access,
                       S_Stub_Subdirs    'Access,
+                      S_Stub_Subunits   'Access,
                       S_Stub_Tree       'Access,
                       S_Stub_Verbose    'Access);