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> 2011-08-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Iteration_Scheme): For an Ada2012 iterator with * sem_ch5.adb (Analyze_Iteration_Scheme): For an Ada2012 iterator with
...@@ -182,11 +213,6 @@ ...@@ -182,11 +213,6 @@
* s-stusta.adb (Print): Make sure Pos is always initialized to a * s-stusta.adb (Print): Make sure Pos is always initialized to a
suitable value. 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> 2011-08-02 Geert Bosch <bosch@adacore.com>
* a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image. * a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image.
......
gcc/ada/einfo.adb
...@@ -284,7 +284,7 @@ package body Einfo is ...@@ -284,7 +284,7 @@ package body Einfo is
-- Referenced_As_LHS Flag36 -- Referenced_As_LHS Flag36
-- Is_Known_Non_Null Flag37 -- Is_Known_Non_Null Flag37
-- Can_Never_Be_Null Flag38 -- Can_Never_Be_Null Flag38
-- Has_Default_Value Flag39 -- Has_Default_Aspect Flag39
-- Body_Needed_For_SAL Flag40 -- Body_Needed_For_SAL Flag40
-- Treat_As_Volatile Flag41 -- Treat_As_Volatile Flag41
...@@ -408,7 +408,6 @@ package body Einfo is ...@@ -408,7 +408,6 @@ package body Einfo is
-- Is_Compilation_Unit Flag149 -- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150 -- Has_Pragma_Elaborate_Body Flag150
-- Has_Default_Component_Value Flag151
-- Entry_Accepted Flag152 -- Entry_Accepted Flag152
-- Is_Obsolescent Flag153 -- Is_Obsolescent Flag153
-- Has_Per_Object_Constraint Flag154 -- Has_Per_Object_Constraint Flag154
...@@ -518,6 +517,7 @@ package body Einfo is ...@@ -518,6 +517,7 @@ package body Einfo is
-- Is_Safe_To_Reevaluate Flag249 -- Is_Safe_To_Reevaluate Flag249
-- Has_Predicates Flag250 -- Has_Predicates Flag250
-- (unused) Flag151
-- (unused) Flag251 -- (unused) Flag251
-- (unused) Flag252 -- (unused) Flag252
-- (unused) Flag253 -- (unused) Flag253
...@@ -1227,17 +1227,10 @@ package body Einfo is ...@@ -1227,17 +1227,10 @@ package body Einfo is
return Flag119 (Id); return Flag119 (Id);
end Has_Convention_Pragma; end Has_Convention_Pragma;
function Has_Default_Component_Value (Id : E) return B is function Has_Default_Aspect (Id : E) return B is
begin 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)); return Flag39 (Base_Type (Id));
end Has_Default_Value; end Has_Default_Aspect;
function Has_Delayed_Aspects (Id : E) return B is function Has_Delayed_Aspects (Id : E) return B is
begin begin
...@@ -3687,17 +3680,13 @@ package body Einfo is ...@@ -3687,17 +3680,13 @@ package body Einfo is
Set_Flag119 (Id, V); Set_Flag119 (Id, V);
end Set_Has_Convention_Pragma; 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 begin
pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id)); pragma Assert
Set_Flag151 (Id, V); ((Is_Scalar_Type (Id) or else Is_Array_Type (Id))
end Set_Has_Default_Component_Value; and then Is_Base_Type (Id));
procedure Set_Has_Default_Value (Id : E; V : B := True) is
begin
pragma Assert (Is_Scalar_Type (Id) and then Is_Base_Type (Id));
Set_Flag39 (Id, V); 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 procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
begin begin
...@@ -7379,8 +7368,7 @@ package body Einfo is ...@@ -7379,8 +7368,7 @@ package body Einfo is
W ("Has_Controlled_Component", Flag43 (Id)); W ("Has_Controlled_Component", Flag43 (Id));
W ("Has_Controlling_Result", Flag98 (Id)); W ("Has_Controlling_Result", Flag98 (Id));
W ("Has_Convention_Pragma", Flag119 (Id)); W ("Has_Convention_Pragma", Flag119 (Id));
W ("Has_Default_Component_Value", Flag151 (Id)); W ("Has_Default_Aspect", Flag39 (Id));
W ("Has_Default_Value", Flag39 (Id));
W ("Has_Delayed_Aspects", Flag200 (Id)); W ("Has_Delayed_Aspects", Flag200 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id)); W ("Has_Delayed_Freeze", Flag18 (Id));
W ("Has_Discriminants", Flag5 (Id)); W ("Has_Discriminants", Flag5 (Id));
......
gcc/ada/exp_ch13.adb
...@@ -240,8 +240,14 @@ package body Exp_Ch13 is ...@@ -240,8 +240,14 @@ package body Exp_Ch13 is
and then Entity (Ritem) = E and then Entity (Ritem) = E
then then
Aitem := Aspect_Rep_Item (Ritem); 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; end if;
Next_Rep_Item (Ritem); Next_Rep_Item (Ritem);
......
gcc/ada/exp_ch3.adb
...@@ -583,11 +583,23 @@ package body Exp_Ch3 is ...@@ -583,11 +583,23 @@ package body Exp_Ch3 is
Prefix => Make_Identifier (Loc, Name_uInit), Prefix => Make_Identifier (Loc, Name_uInit),
Expressions => Index_List); Expressions => Index_List);
if Needs_Simple_Initialization (Comp_Type) then if Has_Default_Aspect (A_Type) then
Set_Assignment_OK (Comp); Set_Assignment_OK (Comp);
return New_List ( return New_List (
Make_Assignment_Statement (Loc, 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 => Expression =>
Get_Simple_Init_Val Get_Simple_Init_Val
(Comp_Type, Nod, Component_Size (A_Type)))); (Comp_Type, Nod, Component_Size (A_Type))));
...@@ -617,6 +629,7 @@ package body Exp_Ch3 is ...@@ -617,6 +629,7 @@ package body Exp_Ch3 is
if not Has_Non_Null_Base_Init_Proc (Comp_Type) if not Has_Non_Null_Base_Init_Proc (Comp_Type)
and then not Needs_Simple_Initialization (Comp_Type) and then not Needs_Simple_Initialization (Comp_Type)
and then not Has_Task (Comp_Type) and then not Has_Task (Comp_Type)
and then not Has_Default_Aspect (A_Type)
then then
return New_List (Make_Null_Statement (Loc)); return New_List (Make_Null_Statement (Loc));
...@@ -678,6 +691,7 @@ package body Exp_Ch3 is ...@@ -678,6 +691,7 @@ package body Exp_Ch3 is
-- 2. The component type needs simple initialization -- 2. The component type needs simple initialization
-- 3. Tasks are present -- 3. Tasks are present
-- 4. The type is marked as a public entity -- 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 -- 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 -- Initialize_Scalars pragma. This pragma can be set in the client and
...@@ -695,7 +709,8 @@ package body Exp_Ch3 is ...@@ -695,7 +709,8 @@ package body Exp_Ch3 is
Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
or else Needs_Simple_Initialization (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 if Has_Default_Init
or else (not Restriction_Active (No_Initialize_Scalars) or else (not Restriction_Active (No_Initialize_Scalars)
...@@ -777,7 +792,7 @@ package body Exp_Ch3 is ...@@ -777,7 +792,7 @@ package body Exp_Ch3 is
Set_Is_Null_Init_Proc (Proc_Id); Set_Is_Null_Init_Proc (Proc_Id);
else 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 -- objects of the type. This can only be done for constrained
-- one-dimensional arrays with static bounds. -- one-dimensional arrays with static bounds.
...@@ -4831,11 +4846,11 @@ package body Exp_Ch3 is ...@@ -4831,11 +4846,11 @@ package body Exp_Ch3 is
begin begin
-- If the original node of the expression was a conversion -- If the original node of the expression was a conversion
-- to this specific class-wide interface type then we -- to this specific class-wide interface type then restore
-- restore the original node because we must copy the object -- the original node because we must copy the object before
-- before displacing the pointer to reference the secondary -- displacing the pointer to reference the secondary tag
-- tag component. This code must be kept synchronized with -- component. This code must be kept synchronized with the
-- the expansion done by routine Expand_Interface_Conversion -- expansion done by routine Expand_Interface_Conversion
if not Comes_From_Source (Expr_N) if not Comes_From_Source (Expr_N)
and then Nkind (Expr_N) = N_Explicit_Dereference and then Nkind (Expr_N) = N_Explicit_Dereference
...@@ -6885,8 +6900,17 @@ package body Exp_Ch3 is ...@@ -6885,8 +6900,17 @@ package body Exp_Ch3 is
return Result; return Result;
-- For scalars, we must have normalize/initialize scalars case, or -- Scalars with Default_Value aspect
-- if the node N is an 'Invalid_Value attribute node.
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 elsif Is_Scalar_Type (T) then
pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
...@@ -8522,6 +8546,11 @@ package body Exp_Ch3 is ...@@ -8522,6 +8546,11 @@ package body Exp_Ch3 is
end if; end if;
end; 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 -- Cases needing simple initialization are access types, and, if pragma
-- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
-- types. -- types.
......
gcc/ada/exp_ch3.ads
...@@ -130,14 +130,14 @@ package Exp_Ch3 is ...@@ -130,14 +130,14 @@ package Exp_Ch3 is
(T : Entity_Id; (T : Entity_Id;
Consider_IS : Boolean := True) return Boolean; Consider_IS : Boolean := True) return Boolean;
-- Certain types need initialization even though there is no specific -- Certain types need initialization even though there is no specific
-- initialization routine. In this category are access types (which need -- initialization routine:
-- initializing to null), packed array types whose implementation is a -- Access types (which need initializing to null)
-- modular type, and all scalar types if Normalize_Scalars is set, as well -- All scalar types if Normalize_Scalars mode set
-- as private types whose underlying type is present and meets any of these -- Descendents of standard string types if Normalize_Scalars mode set
-- criteria. Finally, descendants of String and Wide_String also need -- Scalar types having a Default_Value attribute
-- initialization in Initialize/Normalize_Scalars mode. Consider_IS is -- Regarding Initialize_Scalars mode, this is ignored if Consider_IS is
-- normally True. If it is False, the Initialize_Scalars is not considered -- set to False, but if Consider_IS is set to True, then the cases above
-- in determining whether simple initialization is needed. -- mentioning Normalize_Scalars also apply for Initialize_Scalars mode.
function Get_Simple_Init_Val function Get_Simple_Init_Val
(T : Entity_Id; (T : Entity_Id;
......
gcc/ada/exp_ch5.adb
...@@ -2860,7 +2860,7 @@ package body Exp_Ch5 is ...@@ -2860,7 +2860,7 @@ package body Exp_Ch5 is
declare declare
Element_Type : constant Entity_Id := Etype (Id); 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_Init : Name_Id;
Name_Step : Name_Id; Name_Step : Name_Id;
Cond : Node_Id; Cond : Node_Id;
...@@ -2915,7 +2915,11 @@ package body Exp_Ch5 is ...@@ -2915,7 +2915,11 @@ package body Exp_Ch5 is
if Of_Present (I_Spec) then 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 := Renaming_Decl :=
Make_Object_Renaming_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
......
gcc/ada/freeze.adb
...@@ -2423,8 +2423,14 @@ package body Freeze is ...@@ -2423,8 +2423,14 @@ package body Freeze is
and then Is_Delayed_Aspect (Ritem) and then Is_Delayed_Aspect (Ritem)
then then
Aitem := Aspect_Rep_Item (Ritem); 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; end if;
Next_Rep_Item (Ritem); Next_Rep_Item (Ritem);
...@@ -4018,11 +4024,11 @@ package body Freeze is ...@@ -4018,11 +4024,11 @@ package body Freeze is
end if; end if;
end if; end if;
-- Remaining process is to set/verify the representation information, -- Now we set/verify the representation information, in particular
-- in particular the size and alignment values. This processing is -- the size and alignment values. This processing is not required for
-- not required for generic types, since generic types do not play -- generic types, since generic types do not play any part in code
-- any part in code generation, and so the size and alignment values -- generation, and so the size and alignment values for such types
-- for such types are irrelevant. -- are irrelevant.
if Is_Generic_Type (E) then if Is_Generic_Type (E) then
return Result; return Result;
...@@ -4033,6 +4039,42 @@ package body Freeze is ...@@ -4033,6 +4039,42 @@ package body Freeze is
Layout_Type (E); Layout_Type (E);
end if; 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 of freeze processing for type entities
end if; end if;
......
gcc/ada/init.c
...@@ -2026,7 +2026,7 @@ __gnat_init_float (void) ...@@ -2026,7 +2026,7 @@ __gnat_init_float (void)
to get correct Ada semantics. Note that for AE653 vThreads, the HW to get correct Ada semantics. Note that for AE653 vThreads, the HW
overflow settings are an OS configuration issue. The instructions overflow settings are an OS configuration issue. The instructions
below have no effect. */ 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__) #if defined (__SPE__)
{ {
const unsigned long spefscr_mask = 0xfffffff3; const unsigned long spefscr_mask = 0xfffffff3;
......
gcc/ada/par-prag.adb
...@@ -1136,8 +1136,6 @@ begin ...@@ -1136,8 +1136,6 @@ begin
Pragma_Controlled | Pragma_Controlled |
Pragma_Convention | Pragma_Convention |
Pragma_Debug_Policy | Pragma_Debug_Policy |
Pragma_Default_Value |
Pragma_Default_Component_Value |
Pragma_Detect_Blocking | Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool | Pragma_Default_Storage_Pool |
Pragma_Dimension | Pragma_Dimension |
......
gcc/ada/sem_attr.adb
...@@ -85,61 +85,61 @@ package body Sem_Attr is ...@@ -85,61 +85,61 @@ package body Sem_Attr is
-- that are not included in Ada 95, but still get recognized in GNAT. -- that are not included in Ada 95, but still get recognized in GNAT.
Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Address | Attribute_Address |
Attribute_Aft | Attribute_Aft |
Attribute_Alignment | Attribute_Alignment |
Attribute_Base | Attribute_Base |
Attribute_Callable | Attribute_Callable |
Attribute_Constrained | Attribute_Constrained |
Attribute_Count | Attribute_Count |
Attribute_Delta | Attribute_Delta |
Attribute_Digits | Attribute_Digits |
Attribute_Emax | Attribute_Emax |
Attribute_Epsilon | Attribute_Epsilon |
Attribute_First | Attribute_First |
Attribute_First_Bit | Attribute_First_Bit |
Attribute_Fore | Attribute_Fore |
Attribute_Image | Attribute_Image |
Attribute_Large | Attribute_Large |
Attribute_Last | Attribute_Last |
Attribute_Last_Bit | Attribute_Last_Bit |
Attribute_Leading_Part | Attribute_Leading_Part |
Attribute_Length | Attribute_Length |
Attribute_Machine_Emax | Attribute_Machine_Emax |
Attribute_Machine_Emin | Attribute_Machine_Emin |
Attribute_Machine_Mantissa | Attribute_Machine_Mantissa |
Attribute_Machine_Overflows | Attribute_Machine_Overflows |
Attribute_Machine_Radix | Attribute_Machine_Radix |
Attribute_Machine_Rounds | Attribute_Machine_Rounds |
Attribute_Mantissa | Attribute_Mantissa |
Attribute_Pos | Attribute_Pos |
Attribute_Position | Attribute_Position |
Attribute_Pred | Attribute_Pred |
Attribute_Range | Attribute_Range |
Attribute_Safe_Emax | Attribute_Safe_Emax |
Attribute_Safe_Large | Attribute_Safe_Large |
Attribute_Safe_Small | Attribute_Safe_Small |
Attribute_Size | Attribute_Size |
Attribute_Small | Attribute_Small |
Attribute_Storage_Size | Attribute_Storage_Size |
Attribute_Succ | Attribute_Succ |
Attribute_Terminated | Attribute_Terminated |
Attribute_Val | Attribute_Val |
Attribute_Value | Attribute_Value |
Attribute_Width => True, Attribute_Width => True,
others => False); others => False);
-- The following array is the list of attributes defined in the Ada 2005 -- 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, -- 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. -- but in Ada 95 they are considered to be implementation defined.
Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Machine_Rounding | Attribute_Machine_Rounding |
Attribute_Mod | Attribute_Mod |
Attribute_Priority | Attribute_Priority |
Attribute_Stream_Size | Attribute_Stream_Size |
Attribute_Wide_Wide_Width => True, Attribute_Wide_Wide_Width => True,
others => False); others => False);
-- The following array contains all attributes that imply a modification -- The following array contains all attributes that imply a modification
-- of their prefixes or result in an access value. Such prefixes can be -- of their prefixes or result in an access value. Such prefixes can be
...@@ -147,13 +147,13 @@ package body Sem_Attr is ...@@ -147,13 +147,13 @@ package body Sem_Attr is
Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array := Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
Attribute_Class_Array'( Attribute_Class_Array'(
Attribute_Access | Attribute_Access |
Attribute_Address | Attribute_Address |
Attribute_Input | Attribute_Input |
Attribute_Read | Attribute_Read |
Attribute_Unchecked_Access | Attribute_Unchecked_Access |
Attribute_Unrestricted_Access => True, Attribute_Unrestricted_Access => True,
others => False); others => False);
----------------------- -----------------------
-- Local_Subprograms -- -- Local_Subprograms --
...@@ -1870,9 +1870,7 @@ package body Sem_Attr is ...@@ -1870,9 +1870,7 @@ package body Sem_Attr is
end if; end if;
end Validate_Non_Static_Attribute_Function_Call; end Validate_Non_Static_Attribute_Function_Call;
----------------------------------------------- -- Start of processing for Analyze_Attribute
-- Start of Processing for Analyze_Attribute --
-----------------------------------------------
begin begin
-- Immediate return if unrecognized attribute (already diagnosed -- Immediate return if unrecognized attribute (already diagnosed
...@@ -1897,9 +1895,9 @@ package body Sem_Attr is ...@@ -1897,9 +1895,9 @@ package body Sem_Attr is
end if; end if;
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); Check_Restriction (No_Implementation_Attributes, N);
end if; end if;
...@@ -6016,13 +6014,6 @@ package body Sem_Attr is ...@@ -6016,13 +6014,6 @@ package body Sem_Attr is
Eval_Fat.Copy_Sign Eval_Fat.Copy_Sign
(P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static); (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 -- -- Definite --
-------------- --------------
...@@ -6032,6 +6023,13 @@ package body Sem_Attr is ...@@ -6032,6 +6023,13 @@ package body Sem_Attr is
Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc)); Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
Analyze_And_Resolve (N, Standard_Boolean); Analyze_And_Resolve (N, Standard_Boolean);
-----------
-- Delta --
-----------
when Attribute_Delta =>
Fold_Ureal (N, Delta_Value (P_Type), True);
------------ ------------
-- Denorm -- -- Denorm --
------------ ------------
......
gcc/ada/sem_ch5.adb
...@@ -2261,7 +2261,7 @@ package body Sem_Ch5 is ...@@ -2261,7 +2261,7 @@ package body Sem_Ch5 is
-- Find the Element_Type in the package instance that defines the -- Find the Element_Type in the package instance that defines the
-- container type. -- container type.
Ent := First_Entity (Scope (Typ)); Ent := First_Entity (Scope (Base_Type (Typ)));
while Present (Ent) loop while Present (Ent) loop
if Chars (Ent) = Name_Element_Type then if Chars (Ent) = Name_Element_Type then
Set_Etype (Def_Id, Ent); Set_Etype (Def_Id, Ent);
...@@ -2274,7 +2274,7 @@ package body Sem_Ch5 is ...@@ -2274,7 +2274,7 @@ package body Sem_Ch5 is
else else
-- Find the Cursor type in similar fashion -- Find the Cursor type in similar fashion
Ent := First_Entity (Scope (Typ)); Ent := First_Entity (Scope (Base_Type (Typ)));
while Present (Ent) loop while Present (Ent) loop
if Chars (Ent) = Name_Cursor then if Chars (Ent) = Name_Cursor then
Set_Etype (Def_Id, Ent); Set_Etype (Def_Id, Ent);
......
gcc/ada/sem_prag.adb
...@@ -7352,139 +7352,6 @@ package body Sem_Prag is ...@@ -7352,139 +7352,6 @@ package body Sem_Prag is
Debug_Pragmas_Enabled := Debug_Pragmas_Enabled :=
Chars (Get_Pragma_Arg (Arg1)) = Name_Check; 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 -- -- Detect_Blocking --
--------------------- ---------------------
...@@ -14111,8 +13978,6 @@ package body Sem_Prag is ...@@ -14111,8 +13978,6 @@ package body Sem_Prag is
Pragma_Convention_Identifier => 0, Pragma_Convention_Identifier => 0,
Pragma_Debug => -1, Pragma_Debug => -1,
Pragma_Debug_Policy => 0, Pragma_Debug_Policy => 0,
Pragma_Default_Value => -1,
Pragma_Default_Component_Value => -1,
Pragma_Detect_Blocking => -1, Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1, Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1, Pragma_Dimension => -1,
......
gcc/ada/snames.ads-tmpl
...@@ -137,6 +137,8 @@ package Snames is ...@@ -137,6 +137,8 @@ package Snames is
-- Names of aspects for which there are no matching pragmas or attributes -- Names of aspects for which there are no matching pragmas or attributes
-- so that they need to be included for aspect specification use. -- 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_Dynamic_Predicate : constant Name_Id := N + $;
Name_Post : constant Name_Id := N + $; Name_Post : constant Name_Id := N + $;
Name_Pre : constant Name_Id := N + $; Name_Pre : constant Name_Id := N + $;
...@@ -447,8 +449,6 @@ package Snames is ...@@ -447,8 +449,6 @@ package Snames is
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
Name_CPU : constant Name_Id := N + $; -- Ada 12 Name_CPU : constant Name_Id := N + $; -- Ada 12
Name_Debug : constant Name_Id := N + $; -- GNAT 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_Dimension : constant Name_Id := N + $; -- GNAT
Name_Elaborate : constant Name_Id := N + $; -- Ada 83 Name_Elaborate : constant Name_Id := N + $; -- Ada 83
Name_Elaborate_All : constant Name_Id := N + $; Name_Elaborate_All : constant Name_Id := N + $;
...@@ -1554,8 +1554,6 @@ package Snames is ...@@ -1554,8 +1554,6 @@ package Snames is
Pragma_CPP_Vtable, Pragma_CPP_Vtable,
Pragma_CPU, Pragma_CPU,
Pragma_Debug, Pragma_Debug,
Pragma_Default_Value,
Pragma_Default_Component_Value,
Pragma_Dimension, Pragma_Dimension,
Pragma_Elaborate, Pragma_Elaborate,
Pragma_Elaborate_All, 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