+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.
g-expect$(objext) \
g-exptty$(objext) \
g-flocon$(objext) \
+ g-forstr$(objext) \
g-heasor$(objext) \
g-hesora$(objext) \
g-hesorg$(objext) \
(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,
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,
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,
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
* 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)::
* 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)::
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})
@findex gnatstub
@noindent
-@command{gnatstub} creates body stubs, that is, empty but compilable bodies
-for library unit declarations.
+@command{gnatstub} creates empty but compilable bodies
+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,
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).
@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
@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
-information.
-The file name does not have to follow the GNAT file name conventions. If the
-name
-does not follow GNAT file naming conventions, the name of the body file must
+for which a body must be created or a library unit body for which subunits
+must be created for the body stubs declared in this body.
+The file name may contain the path information.
+If the name does not follow GNAT file naming conventions and a set
+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
-of the body file from the argument file name by replacing the @file{.ads}
-suffix
-with the @file{.adb} suffix.
-
-@item directory
-indicates the directory in which the body stub is to be placed (the default
-is the
-current directory)
+takes the naming conventions for the generated source from the
+project file provided as a parameter of @option{-P} switch if any,
+or creates the name file to generate using the standard GNAT
+naming conventions.
@item @samp{@var{gcc_switches}} is a list of switches for
@command{gcc}. They will be passed on to all compiler invocations made by
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})
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.
("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
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),
-- 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;
(N : Node_Id;
Expr_Val : out Boolean)
is
- Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
- Obj : constant Node_Id := Get_Pragma_Arg (Arg1);
- Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1));
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
+ Obj_Id : constant Entity_Id := Entity (Get_Pragma_Arg (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
- -- than a formal subprogram parameter (SPARK RM 7.1.3(2)).
+ -- An external property pragma must apply to a volatile object other
+ -- 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 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
+ if not Is_SPARK_Volatile (Obj_Id) then
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;
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;
Pragma_Effective_Writes =>
Async_Effective : declare
Duplic : Node_Id;
+ Expr : Node_Id;
+ Obj : Node_Id;
Obj_Id : Entity_Id;
begin
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
- Obj_Id := Entity (Get_Pragma_Arg (Arg1));
+ if Is_Entity_Name (Obj)
+ 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
- -- to detect duplicate pragmas as Boolean aspects may appear
+ -- Detect a duplicate pragma. Note that it is not efficient to
+ -- 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
- Error_Msg_Name_1 := Pname;
- Error_Msg_Sloc := Sloc (Duplic);
- Error_Msg_N ("pragma % duplicates pragma declared #", N);
+ if Present (Duplic) then
+ Error_Msg_Sloc := Sloc (Duplic);
+ Error_Msg_N ("pragma % duplicates pragma declared #", N);
- -- Chain the pragma on the contract for further processing.
- -- This also aids in detecting duplicates.
+ -- No duplicate detected
- else
- Add_Contract_Item (N, Obj_Id);
+ else
+ if Present (Expr) then
+ Preanalyze_And_Resolve (Expr, Standard_Boolean);
end if;
- -- The minimum legality requirements have been met, do not
- -- fall through to the error message.
+ -- Chain the pragma on the contract for further processing
- 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;
------------------
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 --
-----------------------------------
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 :=
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
-- 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
- -- such pragmas.
+ -- presence of a property pragma with an optional Boolean flag. The
+ -- property is enabled when the flag evaluates to True or the flag is
+ -- missing altogether.
- elsif Property = Name_Async_Readers
- and then
- (Present (AR)
- or else
- (No (AW) and then No (ER) and then No (EW)))
- then
+ elsif Property = Name_Async_Readers and then Is_Enabled (AR) then
return True;
- elsif Property = Name_Async_Writers
- and then (Present (AW)
- or else (No (AR) and then No (ER) and then No (EW)))
- then
+ elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
return True;
- elsif Property = Name_Effective_Reads
- and then (Present (ER)
- or else (No (AR) and then No (AW) and then No (EW)))
- then
+ elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then
return True;
- elsif Property = Name_Effective_Writes
- and then (Present (EW)
- or else (No (AR) and then No (AW) and then No (ER)))
- then
+ elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then
+ return True;
+
+ -- 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
--
-- 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 " &
-- 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 " &
(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,
S_Stub_Quiet 'Access,
S_Stub_Search 'Access,
S_Stub_Subdirs 'Access,
+ S_Stub_Subunits 'Access,
S_Stub_Tree 'Access,
S_Stub_Verbose 'Access);
projects / thirdparty / gcc.git / commitdiff
