OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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
This commit is contained in:
Arnaud Charlet 2014-07-30 12:29:48 +02:00
parent ac43e11e23
commit 2f6f828536
12 changed files with 1467 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/ada/ChangeLog
View File

@ -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.

1
gcc/ada/Makefile.rtl
View File

@ -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) \

8
gcc/ada/aspects.ads
View File

@ -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,

951
gcc/ada/g-forstr.adb Normal file
View File

@ -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;

285
gcc/ada/g-forstr.ads Normal file
View File

@ -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;

14
gcc/ada/gnat_rm.texi
View File

@ -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})

53
gcc/ada/gnat_ugn.texi
View File

@ -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
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,
@ -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
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
@ -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.

1
gcc/ada/impunit.adb
View File

@ -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

40
gcc/ada/sem_ch13.adb
View File

@ -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;

75
gcc/ada/sem_prag.adb
View File

@ -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));
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;
@ -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
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;
------------------

76
gcc/ada/sem_util.adb
View File

@ -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
-- 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

22
gcc/ada/vms_data.ads
View File

@ -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);