Skip to content

R
riscv-gcc-1
Commit a01b9df6 by Arnaud Charlet
Options

[multiple changes] 

2011-08-02  Robert Dewar  <dewar@adacore.com>

	* sem_attr.adb: Minor reformatting.

2011-08-02  Ed Falis  <falis@adacore.com>

	* init.c: Revert previous change.

2011-08-02  Robert Dewar  <dewar@adacore.com>

	* einfo.adb (Has_Default_Aspect): Replaces Has_Default_Value
	(Has_Default_Component_Value): Removed
	* einfo.ads Comment updates
	(Has_Default_Aspect): Replaces Has_Default_Value
	(Has_Default_Component_Value): Removed
	* exp_ch13.adb
	(Expand_N_Freeze_Entity): Handle Default[_Component]_Value aspects
	* exp_ch3.adb
	(Build_Array_Init_Proc): Handle Default_[Component_]Value aspects
	(Get_Simple_Init_Val): Handle Default_Value aspect
	(Needs_Simple_Initialization): Handle Default_Value aspect
	* exp_ch3.ads: Needs_Simple_Initialization
	* freeze.adb (Freeze_Entity): Handle Default_[Component_]Value aspect
	* par-prag.adb (Pragma_Default[_Component]Value) Removed
	* sem_ch13.adb
	(Analyze_Aspect_Specifications): Fix Default[_Component]_Value aspects
	* sem_prag.adb (Pragma_Default[_Component]Value) Removed
	* snames.ads-tmpl (Pragma_Default[_Component]Value) Removed

2011-08-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch5.adb (Analyze_Iterator_Specification): use base type to locate
	package containing iteration primitives.
	exp_ch5.adb (Expand_Iterator_Loop): ditto.

From-SVN: r177147
parent 75c90775
Showing with 223 additions and 269 deletions
gcc/ada/ChangeLog
2011-08-02 Robert Dewar <dewar@adacore.com>
* sem_attr.adb: Minor reformatting.
2011-08-02 Robert Dewar <dewar@adacore.com>
* einfo.adb (Has_Default_Aspect): Replaces Has_Default_Value
(Has_Default_Component_Value): Removed
* einfo.ads Comment updates
(Has_Default_Aspect): Replaces Has_Default_Value
(Has_Default_Component_Value): Removed
* exp_ch13.adb
(Expand_N_Freeze_Entity): Handle Default[_Component]_Value aspects
* exp_ch3.adb
(Build_Array_Init_Proc): Handle Default_[Component_]Value aspects
(Get_Simple_Init_Val): Handle Default_Value aspect
(Needs_Simple_Initialization): Handle Default_Value aspect
* exp_ch3.ads: Needs_Simple_Initialization
* freeze.adb (Freeze_Entity): Handle Default_[Component_]Value aspect
* par-prag.adb (Pragma_Default[_Component]Value) Removed
* sem_ch13.adb
(Analyze_Aspect_Specifications): Fix Default[_Component]_Value aspects
* sem_prag.adb (Pragma_Default[_Component]Value) Removed
* snames.ads-tmpl (Pragma_Default[_Component]Value) Removed
2011-08-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Iterator_Specification): use base type to locate
package containing iteration primitives.
exp_ch5.adb (Expand_Iterator_Loop): ditto.
2011-08-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Iteration_Scheme): For an Ada2012 iterator with
......@@ -182,11 +213,6 @@
* s-stusta.adb (Print): Make sure Pos is always initialized to a
suitable value.
2011-08-02 Ed Falis <falis@adacore.com>
* init.c: Fix conditional compilation so that the fp initialization is
peformed for the MILS VxWorks Guest OS.
2011-08-02 Geert Bosch <bosch@adacore.com>
* a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image.
......
gcc/ada/einfo.adb
......@@ -284,7 +284,7 @@ package body Einfo is
-- Referenced_As_LHS Flag36
-- Is_Known_Non_Null Flag37
-- Can_Never_Be_Null Flag38
-- Has_Default_Value Flag39
-- Has_Default_Aspect Flag39
-- Body_Needed_For_SAL Flag40
-- Treat_As_Volatile Flag41
......@@ -408,7 +408,6 @@ package body Einfo is
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
-- Has_Default_Component_Value Flag151
-- Entry_Accepted Flag152
-- Is_Obsolescent Flag153
-- Has_Per_Object_Constraint Flag154
......@@ -518,6 +517,7 @@ package body Einfo is
-- Is_Safe_To_Reevaluate Flag249
-- Has_Predicates Flag250
-- (unused) Flag151
-- (unused) Flag251
-- (unused) Flag252
-- (unused) Flag253
......@@ -1227,17 +1227,10 @@ package body Einfo is
return Flag119 (Id);
end Has_Convention_Pragma;
function Has_Default_Component_Value (Id : E) return B is
function Has_Default_Aspect (Id : E) return B is
begin
pragma Assert (Is_Array_Type (Id));
return Flag151 (Base_Type (Id));
end Has_Default_Component_Value;
function Has_Default_Value (Id : E) return B is
begin
pragma Assert (Is_Scalar_Type (Id));
return Flag39 (Base_Type (Id));
end Has_Default_Value;
end Has_Default_Aspect;
function Has_Delayed_Aspects (Id : E) return B is
begin
......@@ -3687,17 +3680,13 @@ package body Einfo is
Set_Flag119 (Id, V);
end Set_Has_Convention_Pragma;
procedure Set_Has_Default_Component_Value (Id : E; V : B := True) is
procedure Set_Has_Default_Aspect (Id : E; V : B := True) is
begin
pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
Set_Flag151 (Id, V);
end Set_Has_Default_Component_Value;
procedure Set_Has_Default_Value (Id : E; V : B := True) is
begin
pragma Assert (Is_Scalar_Type (Id) and then Is_Base_Type (Id));
pragma Assert
((Is_Scalar_Type (Id) or else Is_Array_Type (Id))
and then Is_Base_Type (Id));
Set_Flag39 (Id, V);
end Set_Has_Default_Value;
end Set_Has_Default_Aspect;
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
begin
......@@ -7379,8 +7368,7 @@ package body Einfo is
W ("Has_Controlled_Component", Flag43 (Id));
W ("Has_Controlling_Result", Flag98 (Id));
W ("Has_Convention_Pragma", Flag119 (Id));
W ("Has_Default_Component_Value", Flag151 (Id));
W ("Has_Default_Value", Flag39 (Id));
W ("Has_Default_Aspect", Flag39 (Id));
W ("Has_Delayed_Aspects", Flag200 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id));
W ("Has_Discriminants", Flag5 (Id));
......
gcc/ada/exp_ch13.adb
......@@ -240,8 +240,14 @@ package body Exp_Ch13 is
and then Entity (Ritem) = E
then
Aitem := Aspect_Rep_Item (Ritem);
pragma Assert (Is_Delayed_Aspect (Aitem));
Insert_Before (N, Aitem);
-- Skip this for aspects (e.g. Current_Value) for which
-- there is no corresponding pragma or attribute.
if Present (Aitem) then
pragma Assert (Is_Delayed_Aspect (Aitem));
Insert_Before (N, Aitem);
end if;
end if;
Next_Rep_Item (Ritem);
......
gcc/ada/exp_ch3.adb
......@@ -583,11 +583,23 @@ package body Exp_Ch3 is
Prefix => Make_Identifier (Loc, Name_uInit),
Expressions => Index_List);
if Needs_Simple_Initialization (Comp_Type) then
if Has_Default_Aspect (A_Type) then
Set_Assignment_OK (Comp);
return New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Name => Comp,
Expression =>
Convert_To (Comp_Type,
Expression
(Get_Rep_Item_For_Entity
(First_Subtype (A_Type),
Name_Default_Component_Value)))));
elsif Needs_Simple_Initialization (Comp_Type) then
Set_Assignment_OK (Comp);
return New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression =>
Get_Simple_Init_Val
(Comp_Type, Nod, Component_Size (A_Type))));
......@@ -617,6 +629,7 @@ package body Exp_Ch3 is
if not Has_Non_Null_Base_Init_Proc (Comp_Type)
and then not Needs_Simple_Initialization (Comp_Type)
and then not Has_Task (Comp_Type)
and then not Has_Default_Aspect (A_Type)
then
return New_List (Make_Null_Statement (Loc));
......@@ -678,6 +691,7 @@ package body Exp_Ch3 is
-- 2. The component type needs simple initialization
-- 3. Tasks are present
-- 4. The type is marked as a public entity
-- 5. The array type has a Default_Component_Value aspect
-- The reason for the public entity test is to deal properly with the
-- Initialize_Scalars pragma. This pragma can be set in the client and
......@@ -695,7 +709,8 @@ package body Exp_Ch3 is
Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
or else Needs_Simple_Initialization (Comp_Type)
or else Has_Task (Comp_Type);
or else Has_Task (Comp_Type)
or else Has_Default_Aspect (A_Type);
if Has_Default_Init
or else (not Restriction_Active (No_Initialize_Scalars)
......@@ -777,7 +792,7 @@ package body Exp_Ch3 is
Set_Is_Null_Init_Proc (Proc_Id);
else
-- Try to build a static aggregate to initialize statically
-- Try to build a static aggregate to statically initialize
-- objects of the type. This can only be done for constrained
-- one-dimensional arrays with static bounds.
......@@ -4831,11 +4846,11 @@ package body Exp_Ch3 is
begin
-- If the original node of the expression was a conversion
-- to this specific class-wide interface type then we
-- restore the original node because we must copy the object
-- before displacing the pointer to reference the secondary
-- tag component. This code must be kept synchronized with
-- the expansion done by routine Expand_Interface_Conversion
-- to this specific class-wide interface type then restore
-- the original node because we must copy the object before
-- displacing the pointer to reference the secondary tag
-- component. This code must be kept synchronized with the
-- expansion done by routine Expand_Interface_Conversion
if not Comes_From_Source (Expr_N)
and then Nkind (Expr_N) = N_Explicit_Dereference
......@@ -6885,8 +6900,17 @@ package body Exp_Ch3 is
return Result;
-- For scalars, we must have normalize/initialize scalars case, or
-- if the node N is an 'Invalid_Value attribute node.
-- Scalars with Default_Value aspect
elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
return
Convert_To (T,
Expression
(Get_Rep_Item_For_Entity
(First_Subtype (T), Name_Default_Value)));
-- Othersie, for scalars, we must have normalize/initialize scalars
-- case, or if the node N is an 'Invalid_Value attribute node.
elsif Is_Scalar_Type (T) then
pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
......@@ -8522,6 +8546,11 @@ package body Exp_Ch3 is
end if;
end;
-- Scalar type with Default_Value aspect requires initialization
elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) 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.
......
gcc/ada/exp_ch3.ads
......@@ -130,14 +130,14 @@ package Exp_Ch3 is
(T : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
-- Certain types need initialization even though there is no specific
-- initialization routine. In this category are access types (which need
-- initializing to null), packed array types whose implementation is a
-- modular type, and all scalar types if Normalize_Scalars is set, as well
-- as private types whose underlying type is present and meets any of these
-- criteria. Finally, descendants of String and Wide_String also need
-- initialization in Initialize/Normalize_Scalars mode. Consider_IS is
-- normally True. If it is False, the Initialize_Scalars is not considered
-- in determining whether simple initialization is needed.
-- initialization routine:
-- Access types (which need initializing to null)
-- All scalar types if Normalize_Scalars mode set
-- Descendents 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 Get_Simple_Init_Val
(T : Entity_Id;
......
gcc/ada/exp_ch5.adb
......@@ -2860,7 +2860,7 @@ package body Exp_Ch5 is
declare
Element_Type : constant Entity_Id := Etype (Id);
Pack : constant Entity_Id := Scope (Etype (Container));
Pack : constant Entity_Id := Scope (Base_Type (Typ));
Name_Init : Name_Id;
Name_Step : Name_Id;
Cond : Node_Id;
......@@ -2915,7 +2915,11 @@ package body Exp_Ch5 is
if Of_Present (I_Spec) then
-- Id : Element_Type renames Pack.Element (Cursor);
-- Id : Element_Type renames Container.Element (Cursor);
-- The code below only handles containers where Element is not
-- a primitive operation of the container. This excludes
-- for now the Hi-Lite formal containers.
Renaming_Decl :=
Make_Object_Renaming_Declaration (Loc,
......
gcc/ada/freeze.adb
......@@ -2423,8 +2423,14 @@ package body Freeze is
and then Is_Delayed_Aspect (Ritem)
then
Aitem := Aspect_Rep_Item (Ritem);
Set_Parent (Aitem, Ritem);
Analyze (Aitem);
-- Skip if this is an aspect with no corresponding pragma
-- or attribute definition node (such as Default_Value).
if Present (Aitem) then
Set_Parent (Aitem, Ritem);
Analyze (Aitem);
end if;
end if;
Next_Rep_Item (Ritem);
......@@ -4018,11 +4024,11 @@ package body Freeze is
end if;
end if;
-- Remaining process is to set/verify the representation information,
-- in particular the size and alignment values. This processing is
-- not required for generic types, since generic types do not play
-- any part in code generation, and so the size and alignment values
-- for such types are irrelevant.
-- Now we set/verify the representation information, in particular
-- the size and alignment values. This processing is not required for
-- generic types, since generic types do not play any part in code
-- generation, and so the size and alignment values for such types
-- are irrelevant.
if Is_Generic_Type (E) then
return Result;
......@@ -4033,6 +4039,42 @@ package body Freeze is
Layout_Type (E);
end if;
-- If the type has a Defaut_Value/Default_Component_Value aspect,
-- this is where we analye the expression (after the type is frozen,
-- since in the case of Default_Value, we are analyzing with the
-- type itself, and we treat Default_Component_Value similarly for
-- the sake of uniformity.
if Is_First_Subtype (E) and then Has_Default_Aspect (E) then
declare
Nam : Name_Id;
Aspect : Node_Id;
Exp : Node_Id;
Typ : Entity_Id;
begin
if Is_Scalar_Type (E) then
Nam := Name_Default_Value;
Typ := E;
else
Nam := Name_Default_Component_Value;
Typ := Component_Type (E);
end if;
Aspect := Get_Rep_Item_For_Entity (E, Nam);
Exp := Expression (Aspect);
Analyze_And_Resolve (Exp, Typ);
if Etype (Exp) /= Any_Type then
if not Is_Static_Expression (Exp) then
Error_Msg_Name_1 := Nam;
Flag_Non_Static_Expr
("aspect% requires static expression", Exp);
end if;
end if;
end;
end if;
-- End of freeze processing for type entities
end if;
......
gcc/ada/init.c
......@@ -2026,7 +2026,7 @@ __gnat_init_float (void)
to get correct Ada semantics. Note that for AE653 vThreads, the HW
overflow settings are an OS configuration issue. The instructions
below have no effect. */
#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && (!defined (VTHREADS) || defined (__VXWORKSMILS__))
#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS)
#if defined (__SPE__)
{
const unsigned long spefscr_mask = 0xfffffff3;
......
gcc/ada/par-prag.adb
......@@ -1136,8 +1136,6 @@ begin
Pragma_Controlled |
Pragma_Convention |
Pragma_Debug_Policy |
Pragma_Default_Value |
Pragma_Default_Component_Value |
Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool |
Pragma_Dimension |
......
gcc/ada/sem_attr.adb
......@@ -85,61 +85,61 @@ package body Sem_Attr is
-- that are not included in Ada 95, but still get recognized in GNAT.
Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Address |
Attribute_Aft |
Attribute_Alignment |
Attribute_Base |
Attribute_Callable |
Attribute_Constrained |
Attribute_Count |
Attribute_Delta |
Attribute_Digits |
Attribute_Emax |
Attribute_Epsilon |
Attribute_First |
Attribute_First_Bit |
Attribute_Fore |
Attribute_Image |
Attribute_Large |
Attribute_Last |
Attribute_Last_Bit |
Attribute_Leading_Part |
Attribute_Length |
Attribute_Machine_Emax |
Attribute_Machine_Emin |
Attribute_Machine_Mantissa |
Attribute_Machine_Overflows |
Attribute_Machine_Radix |
Attribute_Machine_Rounds |
Attribute_Mantissa |
Attribute_Pos |
Attribute_Position |
Attribute_Pred |
Attribute_Range |
Attribute_Safe_Emax |
Attribute_Safe_Large |
Attribute_Safe_Small |
Attribute_Size |
Attribute_Small |
Attribute_Storage_Size |
Attribute_Succ |
Attribute_Terminated |
Attribute_Val |
Attribute_Value |
Attribute_Width => True,
others => False);
Attribute_Address |
Attribute_Aft |
Attribute_Alignment |
Attribute_Base |
Attribute_Callable |
Attribute_Constrained |
Attribute_Count |
Attribute_Delta |
Attribute_Digits |
Attribute_Emax |
Attribute_Epsilon |
Attribute_First |
Attribute_First_Bit |
Attribute_Fore |
Attribute_Image |
Attribute_Large |
Attribute_Last |
Attribute_Last_Bit |
Attribute_Leading_Part |
Attribute_Length |
Attribute_Machine_Emax |
Attribute_Machine_Emin |
Attribute_Machine_Mantissa |
Attribute_Machine_Overflows |
Attribute_Machine_Radix |
Attribute_Machine_Rounds |
Attribute_Mantissa |
Attribute_Pos |
Attribute_Position |
Attribute_Pred |
Attribute_Range |
Attribute_Safe_Emax |
Attribute_Safe_Large |
Attribute_Safe_Small |
Attribute_Size |
Attribute_Small |
Attribute_Storage_Size |
Attribute_Succ |
Attribute_Terminated |
Attribute_Val |
Attribute_Value |
Attribute_Width => True,
others => False);
-- The following array is the list of attributes defined in the Ada 2005
-- RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
-- but in Ada 95 they are considered to be implementation defined.
Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Machine_Rounding |
Attribute_Mod |
Attribute_Priority |
Attribute_Stream_Size |
Attribute_Wide_Wide_Width => True,
others => False);
Attribute_Machine_Rounding |
Attribute_Mod |
Attribute_Priority |
Attribute_Stream_Size |
Attribute_Wide_Wide_Width => True,
others => False);
-- The following array contains all attributes that imply a modification
-- of their prefixes or result in an access value. Such prefixes can be
......@@ -147,13 +147,13 @@ package body Sem_Attr is
Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
Attribute_Class_Array'(
Attribute_Access |
Attribute_Address |
Attribute_Input |
Attribute_Read |
Attribute_Unchecked_Access |
Attribute_Unrestricted_Access => True,
others => False);
Attribute_Access |
Attribute_Address |
Attribute_Input |
Attribute_Read |
Attribute_Unchecked_Access |
Attribute_Unrestricted_Access => True,
others => False);
-----------------------
-- Local_Subprograms --
......@@ -1870,9 +1870,7 @@ package body Sem_Attr is
end if;
end Validate_Non_Static_Attribute_Function_Call;
-----------------------------------------------
-- Start of Processing for Analyze_Attribute --
-----------------------------------------------
-- Start of processing for Analyze_Attribute
begin
-- Immediate return if unrecognized attribute (already diagnosed
......@@ -1897,9 +1895,9 @@ package body Sem_Attr is
end if;
end if;
-- Deal with Ada 2005 issues
-- Deal with Ada 2005 attributes that are
if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then
if Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005 then
Check_Restriction (No_Implementation_Attributes, N);
end if;
......@@ -6016,13 +6014,6 @@ package body Sem_Attr is
Eval_Fat.Copy_Sign
(P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
-----------
-- Delta --
-----------
when Attribute_Delta =>
Fold_Ureal (N, Delta_Value (P_Type), True);
--------------
-- Definite --
--------------
......@@ -6032,6 +6023,13 @@ package body Sem_Attr is
Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
Analyze_And_Resolve (N, Standard_Boolean);
-----------
-- Delta --
-----------
when Attribute_Delta =>
Fold_Ureal (N, Delta_Value (P_Type), True);
------------
-- Denorm --
------------
......
gcc/ada/sem_ch5.adb
......@@ -2261,7 +2261,7 @@ package body Sem_Ch5 is
-- Find the Element_Type in the package instance that defines the
-- container type.
Ent := First_Entity (Scope (Typ));
Ent := First_Entity (Scope (Base_Type (Typ)));
while Present (Ent) loop
if Chars (Ent) = Name_Element_Type then
Set_Etype (Def_Id, Ent);
......@@ -2274,7 +2274,7 @@ package body Sem_Ch5 is
else
-- Find the Cursor type in similar fashion
Ent := First_Entity (Scope (Typ));
Ent := First_Entity (Scope (Base_Type (Typ)));
while Present (Ent) loop
if Chars (Ent) = Name_Cursor then
Set_Etype (Def_Id, Ent);
......
gcc/ada/sem_prag.adb
......@@ -7352,139 +7352,6 @@ package body Sem_Prag is
Debug_Pragmas_Enabled :=
Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
-----------------------------
-- Default_Component_Value --
-----------------------------
when Pragma_Default_Component_Value => declare
Arg : Node_Id;
E : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (2);
Check_Arg_Is_Local_Name (Arg1);
Arg := Get_Pragma_Arg (Arg1);
Analyze (Arg);
if Etype (Arg) = Any_Type then
return;
end if;
if not Is_Entity_Name (Arg)
or else not Is_Array_Type (Entity (Arg))
then
Error_Pragma_Arg ("pragma% requires an array type", Arg1);
end if;
Check_First_Subtype (Arg1);
E := Entity (Arg);
Check_Duplicate_Pragma (E);
-- Check for rep item too early or too late, but skip this if
-- the pragma comes from the corresponding aspect, since we do
-- not need the checks, and more importantly, the pragma is on
-- the rep item chain alreay, and must not be put there twice!
if not From_Aspect_Specification (N) then
if Rep_Item_Too_Early (E, N)
or else
Rep_Item_Too_Late (E, N)
then
return;
end if;
end if;
-- Analyze the default value
Arg := Get_Pragma_Arg (Arg2);
Analyze_And_Resolve (Arg, Component_Type (E));
if not Is_OK_Static_Expression (Arg) then
Flag_Non_Static_Expr
("non-static expression not allowed for " &
"Default_Component_Value",
Arg2);
raise Pragma_Exit;
end if;
-- Set the flag on the root type and then check for Rep_Item too
-- early or too late, the latter call chains the pragma onto the
-- Rep_Item chain.
Set_Has_Default_Component_Value (Base_Type (E));
end;
-------------------
-- Default_Value --
-------------------
when Pragma_Default_Value => declare
Arg : Node_Id;
E : Entity_Id;
begin
-- Error checks
GNAT_Pragma;
Check_Arg_Count (2);
Check_Arg_Is_Local_Name (Arg1);
Arg := Get_Pragma_Arg (Arg1);
Analyze (Arg);
if Etype (Arg) = Any_Type then
return;
end if;
if not Is_Entity_Name (Arg)
or else not Is_Scalar_Type (Entity (Arg))
then
Error_Pragma_Arg ("pragma% requires a scalar type", Arg1);
end if;
Check_First_Subtype (Arg1);
E := Entity (Arg);
Check_Duplicate_Pragma (E);
-- Check for rep item too early or too late, but skip this if
-- the pragma comes from the corresponding aspect, since we do
-- not need the checks, and more importantly, the pragma is on
-- the rep item chain alreay, and must not be put there twice!
if not From_Aspect_Specification (N) then
if Rep_Item_Too_Early (E, N)
or else
Rep_Item_Too_Late (E, N)
then
return;
end if;
end if;
-- Analyze the default value. Note that we must do that after
-- checking for Rep_Item_Too_Late since this resolution will
-- freeze the type involved.
Arg := Get_Pragma_Arg (Arg2);
Analyze_And_Resolve (Arg, E);
if not Is_OK_Static_Expression (Arg) then
Flag_Non_Static_Expr
("non-static expression not allowed for Default_Value",
Arg2);
raise Pragma_Exit;
end if;
-- Set the flag on the root type and then check for Rep_Item too
-- early or too late, the latter call chains the pragma onto the
-- Rep_Item chain.
Set_Has_Default_Value (Base_Type (E));
end;
---------------------
-- Detect_Blocking --
---------------------
......@@ -14111,8 +13978,6 @@ package body Sem_Prag is
Pragma_Convention_Identifier => 0,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Default_Value => -1,
Pragma_Default_Component_Value => -1,
Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
......
gcc/ada/snames.ads-tmpl
......@@ -137,6 +137,8 @@ package Snames is
-- Names of aspects for which there are no matching pragmas or attributes
-- so that they need to be included for aspect specification use.
Name_Default_Value : constant Name_Id := N + $;
Name_Default_Component_Value : constant Name_Id := N + $;
Name_Dynamic_Predicate : constant Name_Id := N + $;
Name_Post : constant Name_Id := N + $;
Name_Pre : constant Name_Id := N + $;
......@@ -447,8 +449,6 @@ package Snames is
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
Name_CPU : constant Name_Id := N + $; -- Ada 12
Name_Debug : constant Name_Id := N + $; -- GNAT
Name_Default_Value : constant Name_Id := N + $; -- GNAT
Name_Default_Component_Value : constant Name_Id := N + $; -- GNAT
Name_Dimension : constant Name_Id := N + $; -- GNAT
Name_Elaborate : constant Name_Id := N + $; -- Ada 83
Name_Elaborate_All : constant Name_Id := N + $;
......@@ -1554,8 +1554,6 @@ package Snames is
Pragma_CPP_Vtable,
Pragma_CPU,
Pragma_Debug,
Pragma_Default_Value,
Pragma_Default_Component_Value,
Pragma_Dimension,
Pragma_Elaborate,
Pragma_Elaborate_All,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment