procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] In-place initialization for Initialize_Scalars

Browse source 
This patch optimizes the initialization and allocation of scalar array objects
when pragma Initialize_Scalars is in effect. The patch also extends the syntax
and semantics of pragma Initialize_Scalars to allow for the specification of
invalid values pertaining to families of scalar types. The new syntax is as
follows:

   pragma Initialize_Scalars
     [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];

   TYPE_VALUE_PAIR ::=
     SCALAR_TYPE => static_EXPRESSION

   SCALAR_TYPE :=
     Short_Float
   | Float
   | Long_Float
   | Long_Long_Flat
   | Signed_8
   | Signed_16
   | Signed_32
   | Signed_64
   | Unsigned_8
   | Unsigned_16
   | Unsigned_32
   | Unsigned_64

Depending on the value specified by pragma Initialize_Scalars, the backend may
optimize the creation of the scalar array object into a fast memset.

------------
-- Source --
------------

--  gnat.adc

pragma Initialize_Scalars
  (Short_Float     => 0.0,
   Float           => 0.0,
   Long_Float      => 0.0,
   Long_Long_Float => 0.0,
   Signed_8        => 0,
   Signed_16       => 0,
   Signed_32       => 0,
   Signed_64       => 0,
   Unsigned_8      => 0,
   Unsigned_16     => 0,
   Unsigned_32     => 0,
   Unsigned_64     => 0);

--  types.ads

with System;

package Types is
   Max : constant := 10_000;
   subtype Big is Integer range 1 .. Max;

   type Byte is range 0 .. 255;
   for Byte'Size use System.Storage_Unit;

   type Byte_Arr_1 is array (1 .. Max) of Byte;
   type Byte_Arr_2 is array (Big) of Byte;
   type Byte_Arr_3 is array (Integer range <>) of Byte;
   type Byte_Arr_4 is array (Integer range <>,
                             Integer range <>) of Byte;
   type Constr_Arr_1 is array (1 .. Max) of Integer;
   type Constr_Arr_2 is array (Big) of Integer;
   type Constr_Arr_3 is array (1 .. Max, 1 .. Max) of Integer;
   type Constr_Arr_4 is array (Big, Big) of Integer;

   type Unconstr_Arr_1 is array (Integer range <>) of Integer;
   type Unconstr_Arr_2 is array (Integer range <>,
                                 Integer range <>) of Integer;

   subtype Subt_Arr_1 is Unconstr_Arr_1 (1 .. Max);
   subtype Subt_Arr_2 is Unconstr_Arr_1 (Big);
   subtype Subt_Arr_3 is Unconstr_Arr_2 (1 .. Max, 1 .. Max);
   subtype Subt_Arr_4 is Unconstr_Arr_2 (Big, Big);

   subtype Subt_Str_1 is String (1 .. Max);
   subtype Subt_Str_2 is String (Big);

   type Byte_Arr_1_Ptr     is access Byte_Arr_1;
   type Byte_Arr_2_Ptr     is access Byte_Arr_2;
   type Byte_Arr_3_Ptr     is access Byte_Arr_3;
   type Byte_Arr_4_Ptr     is access Byte_Arr_4;
   type Constr_Arr_1_Ptr   is access Constr_Arr_1;
   type Constr_Arr_2_Ptr   is access Constr_Arr_2;
   type Constr_Arr_3_Ptr   is access Constr_Arr_3;
   type Constr_Arr_4_Ptr   is access Constr_Arr_4;
   type Unconstr_Arr_1_Ptr is access Unconstr_Arr_1;
   type Unconstr_Arr_2_Ptr is access Unconstr_Arr_2;
   type Subt_Arr_1_Ptr     is access Subt_Arr_1;
   type Subt_Arr_2_Ptr     is access Subt_Arr_2;
   type Subt_Arr_3_Ptr     is access Subt_Arr_3;
   type Subt_Arr_4_Ptr     is access Subt_Arr_4;
   type Str_Ptr            is access String;
   type Subt_Str_1_Ptr     is access Subt_Str_1;
   type Subt_Str_2_Ptr     is access Subt_Str_2;
end Types;

--  main.adb

with Types; use Types;

procedure Main is
   Byte_Arr_1_Obj     : Byte_Arr_1;
   Byte_Arr_2_Obj     : Byte_Arr_2;
   Byte_Arr_3_Obj     : Byte_Arr_3 (1 .. Max);
   Byte_Arr_4_Obj     : Byte_Arr_3 (Big);
   Byte_Arr_5_Obj     : Byte_Arr_4 (1 .. Max, 1 .. Max);
   Byte_Arr_6_Obj     : Byte_Arr_4 (Big, Big);
   Constr_Arr_1_Obj   : Constr_Arr_1;
   Constr_Arr_2_Obj   : Constr_Arr_2;
   Constr_Arr_3_Obj   : Constr_Arr_3;
   Constr_Arr_4_Obj   : Constr_Arr_4;
   Unconstr_Arr_1_Obj : Unconstr_Arr_1 (1 .. Max);
   Unconstr_Arr_2_Obj : Unconstr_Arr_1 (Big);
   Unconstr_Arr_3_Obj : Unconstr_Arr_2 (1 .. Max, 1 .. Max);
   Unconstr_Arr_4_Obj : Unconstr_Arr_2 (Big, Big);
   Subt_Arr_1_Obj     : Subt_Arr_1;
   Subt_Arr_2_Obj     : Subt_Arr_2;
   Subt_Arr_3_Obj     : Subt_Arr_3;
   Subt_Arr_4_Obj     : Subt_Arr_4;
   Str_1_Obj          : String (1 .. Max);
   Str_2_Obj          : String (Big);
   Subt_Str_1_Obj     : Subt_Str_1;
   Subt_Str_2_Obj     : Subt_Str_2;

   Byte_Arr_1_Ptr_Obj     : Byte_Arr_1_Ptr     := new Byte_Arr_1;
   Byte_Arr_2_Ptr_Obj     : Byte_Arr_2_Ptr     := new Byte_Arr_2;
   Byte_Arr_3_Ptr_Obj     : Byte_Arr_3_Ptr     := new Byte_Arr_3 (1 .. Max);
   Byte_Arr_4_Ptr_Obj     : Byte_Arr_3_Ptr     := new Byte_Arr_3 (Big);
   Byte_Arr_5_Ptr_Obj     : Byte_Arr_4_Ptr     :=
                              new Byte_Arr_4 (1 .. Max, 1 .. Max);
   Byte_Arr_6_Ptr_Obj     : Byte_Arr_4_Ptr     := new Byte_Arr_4 (Big, Big);
   Constr_Arr_1_Ptr_Obj   : Constr_Arr_1_Ptr   := new Constr_Arr_1;
   Constr_Arr_2_Ptr_Obj   : Constr_Arr_2_Ptr   := new Constr_Arr_2;
   Constr_Arr_3_Ptr_Obj   : Constr_Arr_3_Ptr   := new Constr_Arr_3;
   Constr_Arr_4_Ptr_Obj   : Constr_Arr_4_Ptr   := new Constr_Arr_4;
   Unconstr_Arr_1_Ptr_Obj : Unconstr_Arr_1_Ptr :=
                              new Unconstr_Arr_1 (1 .. Max);
   Unconstr_Arr_2_Ptr_Obj : Unconstr_Arr_1_Ptr := new Unconstr_Arr_1 (Big);
   Unconstr_Arr_3_Ptr_Obj : Unconstr_Arr_2_Ptr :=
                              new Unconstr_Arr_2 (1 .. Max, 1 .. Max);
   Unconstr_Arr_4_Ptr_Obj : Unconstr_Arr_2_Ptr :=
                              new Unconstr_Arr_2 (Big, Big);
   Subt_Arr_1_Ptr_Obj     : Subt_Arr_1_Ptr     := new Subt_Arr_1;
   Subt_Arr_2_Ptr_Obj     : Subt_Arr_2_Ptr     := new Subt_Arr_2;
   Subt_Arr_3_Ptr_Obj     : Subt_Arr_3_Ptr     := new Subt_Arr_3;
   Subt_Arr_4_Ptr_Obj     : Subt_Arr_4_Ptr     := new Subt_Arr_4;
   Str_Ptr_1_Obj          : Str_Ptr            := new String (1 .. Max);
   Str_Ptr_2_Obj          : Str_Ptr            := new String (Big);
   Subt_Str_1_Ptr_Obj     : Subt_Str_1_Ptr     := new Subt_Str_1;
   Subt_Str_2_Ptr_Obj     : Subt_Str_2_Ptr     := new Subt_Str_2;
begin null; end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gcc -c -S -gnatDG -gnatws main.adb
$ grep -c "others => types__TbyteB!(0));" main.adb.dg
$ grep -c "others => integer!(0));" main.adb.dg
$ grep -c "others => character!(0));" main.adb.dg
$ grep -c "others => types__TbyteB!(0));" main.adb.dg
$ grep -c "memset" main.s
8
12
8
8
44

2018-05-22  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Strip away any
	conversions before extracting the value of the expression.
	* exp_ch3.adb (Default_Initialize_Object): Optimize the default
	initialization of an array of scalars.
	(Get_Simple_Init_Val): Add processing for array types. Remove the
	processing of strings because this case is already handled by the array
	case.
	(Needs_Simple_Initialization): Moved to Sem_Util.
	(Simple_Init_Array_Type): New routine.
	(Simple_Init_Initialize_Scalars_Type): Reimplemented to use the new
	facilities from Sem_Util.
	(Simple_Initialization_OK): New routine.
	* exp_ch3.ads (Needs_Simple_Initialization): Moved to Sem_Util.
	* exp_ch4.adb (Expand_N_Allocator): Optimize the default allocation of
	an array of scalars.
	* sem_prag.adb (Analyze_Float_Value): New routine.
	(Analyze_Integer_Value): New routine.
	(Analyze_Pragma): Reimplement the analysis of pragma Initialize_Scalars
	to handled the extended form of the pragma.
	(Analyze_Type_Value_Pair): New routine.
	* sem_util.adb: Add invalid value-related data structures.
	(Examine_Array_Bounds): New routine.
	(Has_Static_Array_Bounds): Reimplemented.
	(Has_Static_Non_Empty_Array_Bounds): New routine.
	(Invalid_Scalar_Value): New routine.
	(Needs_Simple_Initialization): Moved from Exp_Ch3.
	(Set_Invalid_Scalar_Value): New routines.
	* sem_util.ads (Has_Static_Non_Empty_Array_Bounds): New routine.
	(Invalid_Scalar_Value): New routine.
	(Needs_Simple_Initialization): Moved from Exp_Ch3.
	(Set_Invalid_Scalar_Value): New routines.
	* snames.ads-tmpl: Add names for the salar type families used by pragma
	Initialize_Scalars.

From-SVN: r260529
This commit is contained in:
Hristian Kirtchev 2018-05-22 13:26:28 +00:00 • committed by Pierre-Marie de Rodat
parent b00baef5ad
commit 529749b948
9 changed files with 835 additions and 209 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
gcc/ada/ChangeLog
View file

@ -1,3 +1,39 @@
2018-05-22 Hristian Kirtchev <kirtchev@adacore.com>
* exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Strip away any
conversions before extracting the value of the expression.
* exp_ch3.adb (Default_Initialize_Object): Optimize the default
initialization of an array of scalars.
(Get_Simple_Init_Val): Add processing for array types. Remove the
processing of strings because this case is already handled by the array
case.
(Needs_Simple_Initialization): Moved to Sem_Util.
(Simple_Init_Array_Type): New routine.
(Simple_Init_Initialize_Scalars_Type): Reimplemented to use the new
facilities from Sem_Util.
(Simple_Initialization_OK): New routine.
* exp_ch3.ads (Needs_Simple_Initialization): Moved to Sem_Util.
* exp_ch4.adb (Expand_N_Allocator): Optimize the default allocation of
an array of scalars.
* sem_prag.adb (Analyze_Float_Value): New routine.
(Analyze_Integer_Value): New routine.
(Analyze_Pragma): Reimplement the analysis of pragma Initialize_Scalars
to handled the extended form of the pragma.
(Analyze_Type_Value_Pair): New routine.
* sem_util.adb: Add invalid value-related data structures.
(Examine_Array_Bounds): New routine.
(Has_Static_Array_Bounds): Reimplemented.
(Has_Static_Non_Empty_Array_Bounds): New routine.
(Invalid_Scalar_Value): New routine.
(Needs_Simple_Initialization): Moved from Exp_Ch3.
(Set_Invalid_Scalar_Value): New routines.
* sem_util.ads (Has_Static_Non_Empty_Array_Bounds): New routine.
(Invalid_Scalar_Value): New routine.
(Needs_Simple_Initialization): Moved from Exp_Ch3.
(Set_Invalid_Scalar_Value): New routines.
* snames.ads-tmpl: Add names for the salar type families used by pragma
Initialize_Scalars.
2018-05-22 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Make_DT): Initialize the External_Tag with an empty

22
gcc/ada/exp_aggr.adb
View file

@ -4918,20 +4918,21 @@ package body Exp_Aggr is
-- specifically optimized for the target.
function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is
Ctyp : Entity_Id;
Index : Entity_Id;
Expr : Node_Id := N;
Low : Node_Id;
High : Node_Id;
Csiz : Uint;
Ctyp : Entity_Id;
Expr : Node_Id;
High : Node_Id;
Index : Entity_Id;
Low : Node_Id;
Nunits : Int;
Remainder : Uint;
Value : Uint;
Nunits : Nat;
begin
-- Recurse as far as possible to find the innermost component type
Ctyp := Etype (N);
Expr := N;
while Is_Array_Type (Ctyp) loop
if Nkind (Expr) /= N_Aggregate
or else not Is_Others_Aggregate (Expr)
@ -5022,6 +5023,15 @@ package body Exp_Aggr is
Analyze_And_Resolve (Expr, Ctyp);
-- Strip away any conversions from the expression as they simply
-- qualify the real expression.
while Nkind_In (Expr, N_Unchecked_Type_Conversion,
N_Type_Conversion)
loop
Expr := Expression (Expr);
end loop;
Nunits := UI_To_Int (Csiz) / System_Storage_Unit;
if Nunits = 1 then

271
gcc/ada/exp_ch3.adb
View file

@ -5936,6 +5936,11 @@ package body Exp_Ch3 is
-- Return a new reference to Def_Id with attributes Assignment_OK and
-- Must_Not_Freeze already set.
function Simple_Initialization_OK
(Init_Typ : Entity_Id) return Boolean;
-- Determine whether object declaration N with entity Def_Id needs
-- simple initialization, assuming that it is of type Init_Typ.
--------------------------
-- New_Object_Reference --
--------------------------
@ -5957,6 +5962,28 @@ package body Exp_Ch3 is
return Obj_Ref;
end New_Object_Reference;
------------------------------
-- Simple_Initialization_OK --
------------------------------
function Simple_Initialization_OK
(Init_Typ : Entity_Id) return Boolean
is
begin
-- Do not consider the object declaration if it comes with an
-- initialization expression, or is internal in which case it
-- will be assigned later.
return
not Is_Internal (Def_Id)
and then not Has_Init_Expression (N)
and then Needs_Simple_Initialization
(Typ => Init_Typ,
Consider_IS =>
Initialize_Scalars
and then No (Following_Address_Clause (N)));
end Simple_Initialization_OK;
-- Local variables
Exceptions_OK : constant Boolean :=
@ -6041,6 +6068,41 @@ package body Exp_Ch3 is
elsif Build_Equivalent_Aggregate then
null;
-- Optimize the default initialization of an array object when
-- the following conditions are met:
--
-- * Pragma Initialize_Scalars or Normalize_Scalars is in
-- effect.
--
-- * The bounds of the array type are static and lack empty
-- ranges.
--
-- * The array type does not contain atomic components or is
-- treated as packed.
--
-- * The component is of a scalar type which requires simple
-- initialization.
--
-- Construct an in-place initialization aggregate which may be
-- convert into a fast memset by the backend.
elsif Init_Or_Norm_Scalars
and then Is_Array_Type (Typ)
and then not Has_Atomic_Components (Typ)
and then not Is_Packed (Typ)
and then Has_Static_Non_Empty_Array_Bounds (Typ)
and then Is_Scalar_Type (Component_Type (Typ))
and then Simple_Initialization_OK (Component_Type (Typ))
then
Set_No_Initialization (N, False);
Set_Expression (N,
Get_Simple_Init_Val
(Typ => Typ,
N => Obj_Def,
Size => Esize (Def_Id)));
Analyze_And_Resolve (Expression (N), Typ);
-- Otherwise invoke the type init proc, generate:
-- Type_Init_Proc (Obj);
@ -6056,15 +6118,8 @@ package body Exp_Ch3 is
end if;
-- Provide a default value if the object needs simple initialization
-- and does not already have an initial value. A generated temporary
-- does not require initialization because it will be assigned later.
elsif Needs_Simple_Initialization
(Typ, Initialize_Scalars
and then No (Following_Address_Clause (N)))
and then not Is_Internal (Def_Id)
and then not Has_Init_Expression (N)
then
elsif Simple_Initialization_OK (Typ) then
Set_No_Initialization (N, False);
Set_Expression (N,
Get_Simple_Init_Val
@ -7954,6 +8009,9 @@ package body Exp_Ch3 is
-- * Hi_Bound - Set to No_Unit when there is no information available,
-- or to the known high bound.
function Simple_Init_Array_Type return Node_Id;
-- Build an expression to initialize array type Typ
function Simple_Init_Defaulted_Type return Node_Id;
-- Build an expression to initialize type Typ which is subject to
-- aspect Default_Value.
@ -7974,9 +8032,6 @@ package body Exp_Ch3 is
function Simple_Init_Scalar_Type return Node_Id;
-- Build an expression to initialize scalar type Typ
function Simple_Init_String_Type return Node_Id;
-- Build an expression to initialize string type Typ
----------------------------
-- Extract_Subtype_Bounds --
----------------------------
@ -8034,6 +8089,57 @@ package body Exp_Ch3 is
end loop;
end Extract_Subtype_Bounds;
----------------------------
-- Simple_Init_Array_Type --
----------------------------
function Simple_Init_Array_Type return Node_Id is
Comp_Typ : constant Entity_Id := Component_Type (Typ);
function Simple_Init_Dimension (Index : Node_Id) return Node_Id;
-- Initialize a single array dimension with index constraint Index
--------------------
-- Simple_Init_Dimension --
--------------------
function Simple_Init_Dimension (Index : Node_Id) return Node_Id is
begin
-- Process the current dimension
if Present (Index) then
-- Build a suitable "others" aggregate for the next dimension,
-- or initialize the component itself. Generate:
--
-- (others => ...)
return
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (Make_Others_Choice (Loc)),
Expression =>
Simple_Init_Dimension (Next_Index (Index)))));
-- Otherwise all dimensions have been processed. Initialize the
-- component itself.
else
return
Get_Simple_Init_Val
(Typ => Comp_Typ,
N => N,
Size => Esize (Comp_Typ));
end if;
end Simple_Init_Dimension;
-- Start of processing for Simple_Init_Array_Type
begin
return Simple_Init_Dimension (First_Index (Typ));
end Simple_Init_Array_Type;
--------------------------------
-- Simple_Init_Defaulted_Type --
--------------------------------
@ -8080,67 +8186,63 @@ package body Exp_Ch3 is
Float_Typ : Entity_Id;
Hi_Bound : Uint;
Lo_Bound : Uint;
Val_RE : RE_Id;
Scal_Typ : Scalar_Id;
begin
Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);
-- For float types, use float values from System.Scalar_Values
-- Float types
if Is_Floating_Point_Type (Typ) then
Float_Typ := Root_Type (Typ);
if Float_Typ = Standard_Short_Float then
Val_RE := RE_IS_Isf;
Scal_Typ := Name_Short_Float;
elsif Float_Typ = Standard_Float then
Val_RE := RE_IS_Ifl;
Scal_Typ := Name_Float;
elsif Float_Typ = Standard_Long_Float then
Val_RE := RE_IS_Ilf;
Scal_Typ := Name_Long_Float;
else pragma Assert (Float_Typ = Standard_Long_Long_Float);
Val_RE := RE_IS_Ill;
Scal_Typ := Name_Long_Long_Float;
end if;
-- If zero is invalid, use zero values from System.Scalar_Values
-- If zero is invalid, it is a convenient value to use that is for
-- sure an appropriate invalid value in all situations.
elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
if Size_To_Use <= 8 then
Val_RE := RE_IS_Iz1;
elsif Size_To_Use <= 16 then
Val_RE := RE_IS_Iz2;
elsif Size_To_Use <= 32 then
Val_RE := RE_IS_Iz4;
else
Val_RE := RE_IS_Iz8;
end if;
return Make_Integer_Literal (Loc, 0);
-- For unsigned, use unsigned values from System.Scalar_Values
-- Unsigned types
elsif Is_Unsigned_Type (Typ) then
if Size_To_Use <= 8 then
Val_RE := RE_IS_Iu1;
Scal_Typ := Name_Unsigned_8;
elsif Size_To_Use <= 16 then
Val_RE := RE_IS_Iu2;
Scal_Typ := Name_Unsigned_16;
elsif Size_To_Use <= 32 then
Val_RE := RE_IS_Iu4;
Scal_Typ := Name_Unsigned_32;
else
Val_RE := RE_IS_Iu8;
Scal_Typ := Name_Unsigned_64;
end if;
-- For signed, use signed values from System.Scalar_Values
-- Signed types
else
if Size_To_Use <= 8 then
Val_RE := RE_IS_Is1;
Scal_Typ := Name_Signed_8;
elsif Size_To_Use <= 16 then
Val_RE := RE_IS_Is2;
Scal_Typ := Name_Signed_16;
elsif Size_To_Use <= 32 then
Val_RE := RE_IS_Is4;
Scal_Typ := Name_Signed_32;
else
Val_RE := RE_IS_Is8;
Scal_Typ := Name_Signed_64;
end if;
end if;
return New_Occurrence_Of (RTE (Val_RE), Loc);
-- Use the values specified by pragma Initialize_Scalars or the ones
-- provided by the binder. Higher precedence is given to the pragma.
return Invalid_Scalar_Value (Loc, Scal_Typ);
end Simple_Init_Initialize_Scalars_Type;
----------------------------------------
@ -8308,29 +8410,6 @@ package body Exp_Ch3 is
return Expr;
end Simple_Init_Scalar_Type;
-----------------------------
-- Simple_Init_String_Type --
-----------------------------
function Simple_Init_String_Type return Node_Id is
Comp_Typ : constant Entity_Id := Component_Type (Typ);
begin
-- Generate:
-- (others => Get_Simple_Init_Value)
return
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (Make_Others_Choice (Loc)),
Expression =>
Get_Simple_Init_Val
(Typ => Comp_Typ,
N => N,
Size => Esize (Comp_Typ)))));
end Simple_Init_String_Type;
-- Start of processing for Get_Simple_Init_Val
begin
@ -8344,11 +8423,11 @@ package body Exp_Ch3 is
return Simple_Init_Scalar_Type;
end if;
-- [[Wide_]Wide_]String with Initialize or Normalize_Scalars
-- Array type with Initialize or Normalize_Scalars
elsif Is_Standard_String_Type (Typ) then
elsif Is_Array_Type (Typ) then
pragma Assert (Init_Or_Norm_Scalars);
return Simple_Init_String_Type;
return Simple_Init_Array_Type;
-- Access type is initialized to null
@ -10002,70 +10081,6 @@ package body Exp_Ch3 is
end if;
end Make_Tag_Assignment;
---------------------------------
-- Needs_Simple_Initialization --
---------------------------------
function Needs_Simple_Initialization
(Typ : Entity_Id;
Consider_IS : Boolean := True) return Boolean
is
Consider_IS_NS : constant Boolean :=
Normalize_Scalars or (Initialize_Scalars and Consider_IS);
begin
-- Never need initialization if it is suppressed
if Initialization_Suppressed (Typ) then
return False;
end if;
-- Check for private type, in which case test applies to the underlying
-- type of the private type.
if Is_Private_Type (Typ) then
declare
RT : constant Entity_Id := Underlying_Type (Typ);
begin
if Present (RT) then
return Needs_Simple_Initialization (RT);
else
return False;
end if;
end;
-- Scalar type with Default_Value aspect requires initialization
elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then
return True;
-- Cases needing simple initialization are access types, and, if pragma
-- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
-- types.
elsif Is_Access_Type (Typ)
or else (Consider_IS_NS and then (Is_Scalar_Type (Typ)))
then
return True;
-- If Initialize/Normalize_Scalars is in effect, string objects also
-- need initialization, unless they are created in the course of
-- expanding an aggregate (since in the latter case they will be
-- filled with appropriate initializing values before they are used).
elsif Consider_IS_NS
and then Is_Standard_String_Type (Typ)
and then
(not Is_Itype (Typ)
or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate)
then
return True;
else
return False;
end if;
end Needs_Simple_Initialization;
----------------------
-- Predef_Deep_Spec --
----------------------

13
gcc/ada/exp_ch3.ads
View file

@ -134,17 +134,4 @@ package Exp_Ch3 is
-- clause the assignment is handled as part of the freezing of the object,
-- see Check_Address_Clause.
function Needs_Simple_Initialization
(Typ : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
-- Certain types need initialization even though there is no specific
-- initialization routine:
-- Access types (which need initializing to null)
-- All scalar types if Normalize_Scalars mode set
-- Descendants of standard string types if Normalize_Scalars mode set
-- Scalar types having a Default_Value attribute
-- Regarding Initialize_Scalars mode, this is ignored if Consider_IS is
-- set to False, but if Consider_IS is set to True, then the cases above
-- mentioning Normalize_Scalars also apply for Initialize_Scalars mode.
end Exp_Ch3;

63
gcc/ada/exp_ch4.adb
View file

@ -4595,7 +4595,7 @@ package body Exp_Ch4 is
-- first argument to Init must be converted to the task record type.
declare
T : constant Entity_Id := Entity (Expression (N));
T : constant Entity_Id := Etype (Expression (N));
Args : List_Id;
Decls : List_Id;
Decl : Node_Id;
@ -4618,6 +4618,67 @@ package body Exp_Ch4 is
Is_Allocate => True);
end if;
-- Optimize the default allocation of an array object when the
-- following conditions are met:
--
-- * Pragma Initialize_Scalars or Normalize_Scalars is in effect
--
-- * The bounds of the array type are static and lack empty ranges
--
-- * The array type does not contain atomic components or is
-- treated as packed.
--
-- * The component is of a scalar type which requires simple
-- initialization.
--
-- Construct an in-place initialization aggregate which may be
-- convert into a fast memset by the backend.
elsif Init_Or_Norm_Scalars
and then Is_Array_Type (T)
and then not Has_Atomic_Components (T)
and then not Is_Packed (T)
and then Has_Static_Non_Empty_Array_Bounds (T)
and then Is_Scalar_Type (Component_Type (T))
and then Needs_Simple_Initialization
(Typ => Component_Type (T),
Consider_IS => True)
then
Set_Analyzed (N);
Temp := Make_Temporary (Loc, 'P');
-- Generate:
-- Temp : Ptr_Typ := new ...;
Insert_Action
(Assoc_Node => N,
Ins_Action =>
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (PtrT, Loc),
Expression => Relocate_Node (N)),
Suppress => All_Checks);
-- Generate:
-- Temp.all := (others => ...);
Insert_Action
(Assoc_Node => N,
Ins_Action =>
Make_Assignment_Statement (Loc,
Name =>
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Temp, Loc)),
Expression =>
Get_Simple_Init_Val
(Typ => T,
N => N,
Size => Esize (Component_Type (T)))),
Suppress => All_Checks);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
-- Case of no initialization procedure present
elsif not Has_Non_Null_Base_Init_Proc (T) then

180
gcc/ada/sem_prag.adb
View file

@ -17124,24 +17124,190 @@ package body Sem_Prag is
-- Initialize_Scalars --
------------------------
-- pragma Initialize_Scalars;
-- pragma Initialize_Scalars
-- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
when Pragma_Initialize_Scalars =>
-- TYPE_VALUE_PAIR ::=
-- SCALAR_TYPE => static_EXPRESSION
-- SCALAR_TYPE :=
-- Short_Float
-- | Float
-- | Long_Float
-- | Long_Long_Flat
-- | Signed_8
-- | Signed_16
-- | Signed_32
-- | Signed_64
-- | Unsigned_8
-- | Unsigned_16
-- | Unsigned_32
-- | Unsigned_64
when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
Seen : array (Scalar_Id) of Node_Id := (others => Empty);
-- This collection holds the individual pairs which specify the
-- invalid values of their respective scalar types.
procedure Analyze_Float_Value
(Scal_Typ : Float_Scalar_Id;
Val_Expr : Node_Id);
-- Analyze a type value pair associated with float type Scal_Typ
-- and expression Val_Expr.
procedure Analyze_Integer_Value
(Scal_Typ : Integer_Scalar_Id;
Val_Expr : Node_Id);
-- Analyze a type value pair associated with integer type Scal_Typ
-- and expression Val_Expr.
procedure Analyze_Type_Value_Pair (Pair : Node_Id);
-- Analyze type value pair Pair
-------------------------
-- Analyze_Float_Value --
-------------------------
procedure Analyze_Float_Value
(Scal_Typ : Float_Scalar_Id;
Val_Expr : Node_Id)
is
begin
Analyze_And_Resolve (Val_Expr, Any_Real);
if Is_OK_Static_Expression (Val_Expr) then
Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
else
Error_Msg_Name_1 := Scal_Typ;
Error_Msg_N ("value for type % must be static", Val_Expr);
end if;
end Analyze_Float_Value;
---------------------------
-- Analyze_Integer_Value --
---------------------------
procedure Analyze_Integer_Value
(Scal_Typ : Integer_Scalar_Id;
Val_Expr : Node_Id)
is
begin
Analyze_And_Resolve (Val_Expr, Any_Integer);
if Is_OK_Static_Expression (Val_Expr) then
Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
else
Error_Msg_Name_1 := Scal_Typ;
Error_Msg_N ("value for type % must be static", Val_Expr);
end if;
end Analyze_Integer_Value;
-----------------------------
-- Analyze_Type_Value_Pair --
-----------------------------
procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
Scal_Typ : constant Name_Id := Chars (Pair);
Val_Expr : constant Node_Id := Expression (Pair);
Prev_Pair : Node_Id;
begin
if Scal_Typ in Scalar_Id then
Prev_Pair := Seen (Scal_Typ);
-- Prevent multiple attempts to set a value for a scalar
-- type.
if Present (Prev_Pair) then
Error_Msg_Name_1 := Scal_Typ;
Error_Msg_N
("cannot specify multiple invalid values for type %",
Pair);
Error_Msg_Sloc := Sloc (Prev_Pair);
Error_Msg_N ("previous value set #", Pair);
-- Ignore the effects of the pair, but do not halt the
-- analysis of the pragma altogether.
return;
-- Otherwise capture the first pair for this scalar type
else
Seen (Scal_Typ) := Pair;
end if;
if Scal_Typ in Float_Scalar_Id then
Analyze_Float_Value (Scal_Typ, Val_Expr);
else pragma Assert (Scal_Typ in Integer_Scalar_Id);
Analyze_Integer_Value (Scal_Typ, Val_Expr);
end if;
-- Otherwise the scalar family is illegal
else
Error_Msg_Name_1 := Pname;
Error_Msg_N
("argument of pragma % must denote valid scalar family",
Pair);
end if;
end Analyze_Type_Value_Pair;
-- Local variables
Pairs : constant List_Id := Pragma_Argument_Associations (N);
Pair : Node_Id;
-- Start of processing for Do_Initialize_Scalars
begin
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Check_Restriction (No_Initialize_Scalars, N);
-- Ignore the effects of the pragma when No_Initialize_Scalars is
-- in effect.
if Restriction_Active (No_Initialize_Scalars) then
null;
-- Initialize_Scalars creates false positives in CodePeer, and
-- incorrect negative results in GNATprove mode, so ignore this
-- pragma in these modes.
if not Restriction_Active (No_Initialize_Scalars)
and then not (CodePeer_Mode or GNATprove_Mode)
then
elsif CodePeer_Mode or GNATprove_Mode then
null;
-- Otherwise analyze the pragma
else
if Present (Pairs) then
-- Install Standard in order to provide access to primitive
-- types in case the expressions contain attributes such as
-- Integer'Last.
Push_Scope (Standard_Standard);
Pair := First (Pairs);
while Present (Pair) loop
Analyze_Type_Value_Pair (Pair);
Next (Pair);
end loop;
-- Remove Standard
Pop_Scope;
end if;
Init_Or_Norm_Scalars := True;
Initialize_Scalars := True;
Initialize_Scalars := True;
end if;
end Do_Initialize_Scalars;
-----------------
-- Initializes --

400
gcc/ada/sem_util.adb
View file

@ -72,6 +72,25 @@ with GNAT.HTable; use GNAT.HTable;
package body Sem_Util is
---------------------------
-- Local Data Structures --
---------------------------
Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty);
-- A collection to hold the entities of the variables declared in package
-- System.Scalar_Values which describe the invalid values of scalar types.
Invalid_Binder_Values_Set : Boolean := False;
-- This flag prevents multiple attempts to initialize Invalid_Binder_Values
Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal);
-- A collection to hold the invalid values of float types as specified by
-- pragma Initialize_Scalars.
Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint);
-- A collection to hold the invalid values of integer types as specified
-- by pragma Initialize_Scalars.
-----------------------
-- Local Subprograms --
-----------------------
@ -84,6 +103,14 @@ package body Sem_Util is
-- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
-- Loc is the source location, T is the original subtype.
procedure Examine_Array_Bounds
(Typ : Entity_Id;
All_Static : out Boolean;
Has_Empty : out Boolean);
-- Inspect the index constraints of array type Typ. Flag All_Static is set
-- when all ranges are static. Flag Has_Empty is set only when All_Static
-- is set and indicates that at least one range is empty.
function Has_Enabled_Property
(Item_Id : Entity_Id;
Property : Name_Id) return Boolean;
@ -7365,6 +7392,91 @@ package body Sem_Util is
return Id;
end Entity_Of;
--------------------------
-- Examine_Array_Bounds --
--------------------------
procedure Examine_Array_Bounds
(Typ : Entity_Id;
All_Static : out Boolean;
Has_Empty : out Boolean)
is
function Is_OK_Static_Bound (Bound : Node_Id) return Boolean;
-- Determine whether bound Bound is a suitable static bound
------------------------
-- Is_OK_Static_Bound --
------------------------
function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is
begin
return
not Error_Posted (Bound)
and then Is_OK_Static_Expression (Bound);
end Is_OK_Static_Bound;
-- Local variables
Hi_Bound : Node_Id;
Index : Node_Id;
Lo_Bound : Node_Id;
-- Start of processing for Examine_Array_Bounds
begin
-- An unconstrained array type does not have static bounds, and it is
-- not known whether they are empty or not.
if not Is_Constrained (Typ) then
All_Static := False;
Has_Empty := False;
-- A string literal has static bounds, and is not empty as long as it
-- contains at least one character.
elsif Ekind (Typ) = E_String_Literal_Subtype then
All_Static := True;
Has_Empty := String_Literal_Length (Typ) > 0;
end if;
-- Assume that all bounds are static and not empty
All_Static := True;
Has_Empty := False;
-- Examine each index
Index := First_Index (Typ);
while Present (Index) loop
if Is_Discrete_Type (Etype (Index)) then
Get_Index_Bounds (Index, Lo_Bound, Hi_Bound);
if Is_OK_Static_Bound (Lo_Bound)
and then
Is_OK_Static_Bound (Hi_Bound)
then
-- The static bounds produce an empty range
if Is_Null_Range (Lo_Bound, Hi_Bound) then
Has_Empty := True;
end if;
-- Otherwise at least one of the bounds is not static
else
All_Static := False;
end if;
-- Otherwise the index is non-discrete, therefore not static
else
All_Static := False;
end if;
Next_Index (Index);
end loop;
end Examine_Array_Bounds;
--------------------------
-- Explain_Limited_Type --
--------------------------
@ -11372,65 +11484,29 @@ package body Sem_Util is
-----------------------------
function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
Ndims : constant Nat := Number_Dimensions (Typ);
Index : Node_Id;
Low : Node_Id;
High : Node_Id;
All_Static : Boolean;
Dummy : Boolean;
begin
-- Unconstrained types do not have static bounds
Examine_Array_Bounds (Typ, All_Static, Dummy);
if not Is_Constrained (Typ) then
return False;
end if;
-- First treat string literals specially, as the lower bound and length
-- of string literals are not stored like those of arrays.
-- A string literal always has static bounds
if Ekind (Typ) = E_String_Literal_Subtype then
return True;
end if;
-- Treat all dimensions in turn
Index := First_Index (Typ);
for Indx in 1 .. Ndims loop
-- In case of an illegal index which is not a discrete type, return
-- that the type is not static.
if not Is_Discrete_Type (Etype (Index))
or else Etype (Index) = Any_Type
then
return False;
end if;
Get_Index_Bounds (Index, Low, High);
if Error_Posted (Low) or else Error_Posted (High) then
return False;
end if;
if Is_OK_Static_Expression (Low)
and then
Is_OK_Static_Expression (High)
then
null;
else
return False;
end if;
Next (Index);
end loop;
-- If we fall through the loop, all indexes matched
return True;
return All_Static;
end Has_Static_Array_Bounds;
---------------------------------------
-- Has_Static_Non_Empty_Array_Bounds --
---------------------------------------
function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
All_Static : Boolean;
Has_Empty : Boolean;
begin
Examine_Array_Bounds (Typ, All_Static, Has_Empty);
return All_Static and not Has_Empty;
end Has_Static_Non_Empty_Array_Bounds;
----------------
-- Has_Stream --
----------------
@ -12729,6 +12805,124 @@ package body Sem_Util is
SPARK_Mode_Pragma := Prag;
end Install_SPARK_Mode;
--------------------------
-- Invalid_Scalar_Value --
--------------------------
function Invalid_Scalar_Value
(Loc : Source_Ptr;
Scal_Typ : Scalar_Id) return Node_Id
is
function Invalid_Binder_Value return Node_Id;
-- Return a reference to the corresponding invalid value for type
-- Scal_Typ as defined in unit System.Scalar_Values.
function Invalid_Float_Value return Node_Id;
-- Return the invalid value of float type Scal_Typ
function Invalid_Integer_Value return Node_Id;
-- Return the invalid value of integer type Scal_Typ
procedure Set_Invalid_Binder_Values;
-- Set the contents of collection Invalid_Binder_Values
--------------------------
-- Invalid_Binder_Value --
--------------------------
function Invalid_Binder_Value return Node_Id is
Val_Id : Entity_Id;
begin
-- Initialize the collection of invalid binder values the first time
-- around.
Set_Invalid_Binder_Values;
-- Obtain the corresponding variable from System.Scalar_Values which
-- holds the invalid value for this type.
Val_Id := Invalid_Binder_Values (Scal_Typ);
pragma Assert (Present (Val_Id));
return New_Occurrence_Of (Val_Id, Loc);
end Invalid_Binder_Value;
-------------------------
-- Invalid_Float_Value --
-------------------------
function Invalid_Float_Value return Node_Id is
Value : constant Ureal := Invalid_Floats (Scal_Typ);
begin
-- Pragma Invalid_Scalars did not specify an invalid value for this
-- type. Fall back to the value provided by the binder.
if Value = No_Ureal then
return Invalid_Binder_Value;
else
return Make_Real_Literal (Loc, Realval => Value);
end if;
end Invalid_Float_Value;
---------------------------
-- Invalid_Integer_Value --
---------------------------
function Invalid_Integer_Value return Node_Id is
Value : constant Uint := Invalid_Integers (Scal_Typ);
begin
-- Pragma Invalid_Scalars did not specify an invalid value for this
-- type. Fall back to the value provided by the binder.
if Value = No_Uint then
return Invalid_Binder_Value;
else
return Make_Integer_Literal (Loc, Intval => Value);
end if;
end Invalid_Integer_Value;
-------------------------------
-- Set_Invalid_Binder_Values --
-------------------------------
procedure Set_Invalid_Binder_Values is
begin
if not Invalid_Binder_Values_Set then
Invalid_Binder_Values_Set := True;
-- Initialize the contents of the collection once since RTE calls
-- are not cheap.
Invalid_Binder_Values :=
(Name_Short_Float => RTE (RE_IS_Isf),
Name_Float => RTE (RE_IS_Ifl),
Name_Long_Float => RTE (RE_IS_Ilf),
Name_Long_Long_Float => RTE (RE_IS_Ill),
Name_Signed_8 => RTE (RE_IS_Is1),
Name_Signed_16 => RTE (RE_IS_Is2),
Name_Signed_32 => RTE (RE_IS_Is4),
Name_Signed_64 => RTE (RE_IS_Is8),
Name_Unsigned_8 => RTE (RE_IS_Iu1),
Name_Unsigned_16 => RTE (RE_IS_Iu2),
Name_Unsigned_32 => RTE (RE_IS_Iu4),
Name_Unsigned_64 => RTE (RE_IS_Iu8));
end if;
end Set_Invalid_Binder_Values;
-- Start of processing for Invalid_Scalar_Value
begin
if Scal_Typ in Float_Scalar_Id then
return Invalid_Float_Value;
else pragma Assert (Scal_Typ in Integer_Scalar_Id);
return Invalid_Integer_Value;
end if;
end Invalid_Scalar_Value;
-----------------------------
-- Is_Actual_Out_Parameter --
-----------------------------
@ -18771,6 +18965,70 @@ package body Sem_Util is
end if;
end Needs_One_Actual;
---------------------------------
-- Needs_Simple_Initialization --
---------------------------------
function Needs_Simple_Initialization
(Typ : Entity_Id;
Consider_IS : Boolean := True) return Boolean
is
Consider_IS_NS : constant Boolean :=
Normalize_Scalars or (Initialize_Scalars and Consider_IS);
begin
-- Never need initialization if it is suppressed
if Initialization_Suppressed (Typ) then
return False;
end if;
-- Check for private type, in which case test applies to the underlying
-- type of the private type.
if Is_Private_Type (Typ) then
declare
RT : constant Entity_Id := Underlying_Type (Typ);
begin
if Present (RT) then
return Needs_Simple_Initialization (RT);
else
return False;
end if;
end;
-- Scalar type with Default_Value aspect requires initialization
elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then
return True;
-- Cases needing simple initialization are access types, and, if pragma
-- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
-- types.
elsif Is_Access_Type (Typ)
or else (Consider_IS_NS and then (Is_Scalar_Type (Typ)))
then
return True;
-- If Initialize/Normalize_Scalars is in effect, string objects also
-- need initialization, unless they are created in the course of
-- expanding an aggregate (since in the latter case they will be
-- filled with appropriate initializing values before they are used).
elsif Consider_IS_NS
and then Is_Standard_String_Type (Typ)
and then
(not Is_Itype (Typ)
or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate)
then
return True;
else
return False;
end if;
end Needs_Simple_Initialization;
------------------------
-- New_Copy_List_Tree --
------------------------
@ -23782,6 +24040,40 @@ package body Sem_Util is
Set_Entity (N, Val);
end Set_Entity_With_Checks;
------------------------------
-- Set_Invalid_Scalar_Value --
------------------------------
procedure Set_Invalid_Scalar_Value
(Scal_Typ : Float_Scalar_Id;
Value : Ureal)
is
Slot : Ureal renames Invalid_Floats (Scal_Typ);
begin
-- Detect an attempt to set a different value for the same scalar type
pragma Assert (Slot = No_Ureal);
Slot := Value;
end Set_Invalid_Scalar_Value;
------------------------------
-- Set_Invalid_Scalar_Value --
------------------------------
procedure Set_Invalid_Scalar_Value
(Scal_Typ : Integer_Scalar_Id;
Value : Uint)
is
Slot : Uint renames Invalid_Integers (Scal_Typ);
begin
-- Detect an attempt to set a different value for the same scalar type
pragma Assert (Slot = No_Uint);
Slot := Value;
end Set_Invalid_Scalar_Value;
------------------------
-- Set_Name_Entity_Id --
------------------------

35
gcc/ada/sem_util.ads
View file

@ -1325,6 +1325,9 @@ package Sem_Util is
function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean;
-- Return whether an array type has static bounds
function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean;
-- Determine whether array type Typ has static non-empty bounds
function Has_Stream (T : Entity_Id) return Boolean;
-- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or in the
-- case of a composite type, has a component for which this predicate is
@ -1471,6 +1474,13 @@ package Sem_Util is
procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id);
-- Establish the SPARK_Mode and SPARK_Mode_Pragma currently in effect
function Invalid_Scalar_Value
(Loc : Source_Ptr;
Scal_Typ : Scalar_Id) return Node_Id;
-- Obtain the invalid value for scalar type Scal_Typ as either specified by
-- pragma Initialize_Scalars or by the binder. Return an expression created
-- at source location Loc, which denotes the invalid value.
function Is_Actual_Out_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter of out mode in a subprogram call
@ -2183,6 +2193,19 @@ package Sem_Util is
-- syntactic ambiguity that results from an indexing of a function call
-- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y).
function Needs_Simple_Initialization
(Typ : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
-- Certain types need initialization even though there is no specific
-- initialization routine:
-- Access types (which need initializing to null)
-- All scalar types if Normalize_Scalars mode set
-- Descendants of standard string types if Normalize_Scalars mode set
-- Scalar types having a Default_Value attribute
-- Regarding Initialize_Scalars mode, this is ignored if Consider_IS is
-- set to False, but if Consider_IS is set to True, then the cases above
-- mentioning Normalize_Scalars also apply for Initialize_Scalars mode.
function New_Copy_List_Tree (List : List_Id) return List_Id;
-- Copy recursively an analyzed list of nodes. Uses New_Copy_Tree defined
-- below. As for New_Copy_Tree, it is illegal to attempt to copy extended
@ -2633,6 +2656,18 @@ package Sem_Util is
-- If restriction No_Implementation_Identifiers is set, then it checks
-- that the entity is not implementation defined.
procedure Set_Invalid_Scalar_Value
(Scal_Typ : Float_Scalar_Id;
Value : Ureal);
-- Associate invalid value Value with scalar type Scal_Typ as specified by
-- pragma Initialize_Scalars.
procedure Set_Invalid_Scalar_Value
(Scal_Typ : Integer_Scalar_Id;
Value : Uint);
-- Associate invalid value Value with scalar type Scal_Typ as specified by
-- pragma Initialize_Scalars.
procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id);
pragma Inline (Set_Name_Entity_Id);
-- Sets the Entity_Id value associated with the given name, which is the

24
gcc/ada/snames.ads-tmpl
View file

@ -1137,6 +1137,30 @@ package Snames is
Name_Sequential : constant Name_Id := N + $;
Last_Partition_Elaboration_Policy_Name : constant Name_Id := N + $;
-- Names of recognized scalar families for pragma Initialize_Scalars
Name_Short_Float : constant Name_Id := N + $; -- GNAT
Name_Float : constant Name_Id := N + $; -- GNAT
Name_Long_Float : constant Name_Id := N + $; -- GNAT
Name_Long_Long_Float : constant Name_Id := N + $; -- GNAT
Name_Signed_8 : constant Name_Id := N + $; -- GNAT
Name_Signed_16 : constant Name_Id := N + $; -- GNAT
Name_Signed_32 : constant Name_Id := N + $; -- GNAT
Name_Signed_64 : constant Name_Id := N + $; -- GNAT
Name_Unsigned_8 : constant Name_Id := N + $; -- GNAT
Name_Unsigned_16 : constant Name_Id := N + $; -- GNAT
Name_Unsigned_32 : constant Name_Id := N + $; -- GNAT
Name_Unsigned_64 : constant Name_Id := N + $; -- GNAT
subtype Scalar_Id is Name_Id range
Name_Short_Float .. Name_Unsigned_64;
subtype Float_Scalar_Id is Name_Id range
Name_Short_Float .. Name_Long_Long_Float;
subtype Integer_Scalar_Id is Name_Id range
Name_Signed_8 .. Name_Unsigned_64;
-- Names of recognized checks for pragma Suppress
-- Note: the name Atomic_Synchronization can only be specified internally