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 247 additions and 250 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
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
procedure Set_Has_Default_Aspect (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,9 +240,15 @@ package body Exp_Ch13 is
and then Entity (Ritem) = E
then
Aitem := Aspect_Rep_Item (Ritem);
-- 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);
end loop;
......
gcc/ada/exp_ch3.adb
......@@ -583,7 +583,19 @@ 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,
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,
......@@ -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,9 +2423,15 @@ package body Freeze is
and then Is_Delayed_Aspect (Ritem)
then
Aitem := Aspect_Rep_Item (Ritem);
-- 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);
end loop;
......@@ -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
......@@ -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_ch13.adb
......@@ -984,29 +984,6 @@ package body Sem_Ch13 is
-- Aspects corresponding to pragmas with two arguments, where
-- the first argument is a local name referring to the entity,
-- and the second argument is the aspect definition expression
-- which is an expression which must be delayed and analyzed.
when Aspect_Default_Component_Value |
Aspect_Default_Value =>
-- Construct the pragma
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (
New_Occurrence_Of (E, Loc),
Relocate_Node (Expr)),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
-- These aspects do require delaying
Delay_Required := True;
Set_Is_Delayed_Aspect (Aspect);
-- Aspects corresponding to pragmas with two arguments, where
-- the first argument is a local name referring to the entity,
-- and the second argument is the aspect definition expression
-- which is an expression that does not get analyzed.
when Aspect_Suppress |
......@@ -1049,6 +1026,45 @@ package body Sem_Ch13 is
Delay_Required := False;
-- Default_Value and Default_Component_Value aspects. These
-- are specially handled because they have no corresponding
-- pragmas or attributes.
when Aspect_Default_Value | Aspect_Default_Component_Value =>
Error_Msg_Name_1 := Chars (Id);
if not Is_Type (E) then
Error_Msg_N ("aspect% can only apply to a type", Id);
goto Continue;
elsif not Is_First_Subtype (E) then
Error_Msg_N ("aspect% cannot apply to subtype", Id);
goto Continue;
elsif A_Id = Aspect_Default_Value
and then not Is_Scalar_Type (E)
then
Error_Msg_N
("aspect% can only be applied to scalar type", Id);
goto Continue;
elsif A_Id = Aspect_Default_Component_Value then
if not Is_Array_Type (E) then
Error_Msg_N
("aspect% can only be applied to array type", Id);
goto Continue;
elsif not Is_Scalar_Type (Component_Type (E)) then
Error_Msg_N
("aspect% requires scalar components", Id);
goto Continue;
end if;
end if;
Aitem := Empty;
Delay_Required := True;
Set_Is_Delayed_Aspect (Aspect);
Set_Has_Default_Aspect (Base_Type (Entity (Ent)));
-- Aspects Pre/Post generate Precondition/Postcondition pragmas
-- with a first argument that is the expression, and a second
-- argument that is an informative message if the test fails.
......@@ -1218,23 +1234,27 @@ package body Sem_Ch13 is
Delay_Required := True;
end case;
Set_From_Aspect_Specification (Aitem, True);
-- If a delay is required, we delay the freeze (not much point in
-- delaying the aspect if we don't delay the freeze!). The pragma
-- or clause is then attached to the aspect specification which
-- is placed in the rep item list.
-- or attribute clause if there is one is then attached to the
-- aspect specification which is placed in the rep item list.
if Delay_Required then
Ensure_Freeze_Node (E);
if Present (Aitem) then
Set_From_Aspect_Specification (Aitem, True);
Set_Is_Delayed_Aspect (Aitem);
Set_Has_Delayed_Aspects (E);
Set_Aspect_Rep_Item (Aspect, Aitem);
end if;
Ensure_Freeze_Node (E);
Set_Has_Delayed_Aspects (E);
Record_Rep_Item (E, Aspect);
-- If no delay required, insert the pragma/clause in the tree
else
Set_From_Aspect_Specification (Aitem, True);
-- If this is a compilation unit, we will put the pragma in
-- the Pragmas_After list of the N_Compilation_Unit_Aux node.
......@@ -1333,8 +1353,16 @@ package body Sem_Ch13 is
Attr : constant Name_Id := Chars (N);
Expr : constant Node_Id := Expression (N);
Id : constant Attribute_Id := Get_Attribute_Id (Attr);
Ent : Entity_Id;
-- The entity of Nam after it is analyzed. In the case of an incomplete
-- type, this is the underlying type.
U_Ent : Entity_Id;
-- The underlying entity to which the attribute applies. Generally this
-- is the Underlying_Type of Ent, except in the case where the clause
-- applies to full view of incomplete type or private type in which case
-- U_Ent is just a copy of Ent.
FOnly : Boolean := False;
-- Reset to True for subtype specific attribute (Alignment, Size)
......@@ -1366,6 +1394,7 @@ package body Sem_Ch13 is
Pnam : Entity_Id;
Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
-- True for Read attribute, false for other attributes
function Has_Good_Profile (Subp : Entity_Id) return Boolean;
-- Return true if the entity is a subprogram with an appropriate
......@@ -1528,6 +1557,16 @@ package body Sem_Ch13 is
-- Start of processing for Analyze_Attribute_Definition_Clause
begin
-- The following code is a defense against recursion. Not clear that
-- this can happen legitimately, but perhaps some error situations
-- can cause it, and we did see this recursion during testing.
if Analyzed (N) then
return;
else
Set_Analyzed (N, True);
end if;
-- Process Ignore_Rep_Clauses option
if Ignore_Rep_Clauses then
......@@ -1890,6 +1929,7 @@ package body Sem_Ch13 is
-- check till after code generation to take full advantage
-- of the annotation done by the back end. This entry is
-- only made if the address clause comes from source.
-- If the entity has a generic type, the check will be
-- performed in the instance if the actual type justifies
-- it, and we do not insert the clause in the table to
......@@ -2253,7 +2293,6 @@ package body Sem_Ch13 is
("size cannot be given for unconstrained array", Nam);
elsif Size /= No_Uint then
if VM_Target /= No_VM and then not GNAT_Mode then
-- Size clause is not handled properly on VM targets.
......@@ -2443,9 +2482,10 @@ package body Sem_Ch13 is
end if;
-- The Stack_Bounded_Pool is used internally for implementing
-- access types with a Storage_Size. Since it only work
-- properly when used on one specific type, we need to check
-- that it is not hijacked improperly:
-- access types with a Storage_Size. Since it only work properly
-- when used on one specific type, we need to check that it is not
-- hijacked improperly:
-- type T is access Integer;
-- for T'Storage_Size use n;
-- type Q is access Float;
......@@ -2673,9 +2713,9 @@ package body Sem_Ch13 is
("attribute& cannot be set with definition clause", N);
end case;
-- The test for the type being frozen must be performed after
-- any expression the clause has been analyzed since the expression
-- itself might cause freezing that makes the clause illegal.
-- The test for the type being frozen must be performed after any
-- expression the clause has been analyzed since the expression itself
-- might cause freezing that makes the clause illegal.
if Rep_Item_Too_Late (U_Ent, N, FOnly) then
return;
......@@ -3198,11 +3238,12 @@ package body Sem_Ch13 is
Build_Predicate_Function (E, N);
end if;
-- If type has delayed aspects, this is where we do the preanalysis
-- at the freeze point, as part of the consistent visibility check.
-- Note that this must be done after calling Build_Predicate_Function,
-- since that call marks occurrences of the subtype name in the saved
-- expression so that they will not cause trouble in the preanalysis.
-- If type has delayed aspects, this is where we do the preanalysis at
-- the freeze point, as part of the consistent visibility check. Note
-- that this must be done after calling Build_Predicate_Function or
-- Build_Invariant_Procedure since these subprograms fix occurrences of
-- the subtype name in the saved expression so that they will not cause
-- trouble in the preanalysis.
if Has_Delayed_Aspects (E) then
declare
......@@ -6959,7 +7000,9 @@ package body Sem_Ch13 is
if Is_Incomplete_Or_Private_Type (T)
and then No (Underlying_Type (T))
and then Get_Pragma_Id (N) /= Pragma_Import
and then
(Nkind (N) /= N_Pragma
or else Get_Pragma_Id (N) /= Pragma_Import)
then
Error_Msg_N
("representation item must be after full type declaration", N);
......
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