This patch fixes boolean aspects in two respects, first
there is no delay in evaluation of the arguments. The
following compiles clean and executes quietly in -gnata
mode.
1. pragma Ada_2012;
2. procedure baspect1 is
3. type X is array (0 .. 31) of Boolean with
4. Pack => True;
5. True : constant Boolean := False;
6. begin
7. pragma Assert (X'Size = 32);
8. end;
Second, it is no longer allowed to cancel inherited
aspects on derived types, as shown by this example:
1. pragma Ada_2012;
2. package baspect2 is
3. type P is array (0 .. 31) of Boolean with
4. Pack => True;
5. type U is array (0 .. 31) of Boolean with
6. Pack => False;
7. type DP1 is new P with
8. Pack => True; -- OK
9. type DU1 is new U with
10. Pack => False; -- OK
11. type DP2 is new P with
12. Pack => False; -- ERROR
|
>>> derived type "DP2" inherits aspect "pack", cannot cancel
13. type DU2 is new U with
14. Pack => True; -- OK
15. end;
In addition, the calling sequence of Analyze_Aspect_Specification
is changed to improve performance efficiency (some slow down in
compilation time was noticed from the previous implementation).
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-02 Robert Dewar <de...@adacore.com>
* sem_ch12.adb, sem_ch11.adb: New calling sequence for
Analyze_Aspect_Specifications
* sem_ch13.adb
(Analyze_Aspect_Specifications): New handling for boolean aspects
* sem_ch13.ads (Analyze_Aspect_Specifications): New calling sequence
* sem_ch3.adb, sem_ch6.adb, sem_ch7.adb, sem_ch9.adb: New calling
sequence for Analyze_Aspect_Specifications
* sem_prag.adb (Analyze_Pragma): Remove use of Aspect_Cancel entirely
* sinfo.ads, sinfo.adb (Aspect_Cancel): Remove, no longer used
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 177093)
+++ sem_ch3.adb (working copy)
@@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -2016,7 +2015,10 @@
end if;
Set_Original_Record_Component (Id, Id);
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Component_Declaration;
--------------------------
@@ -2491,7 +2493,9 @@
Set_Optimize_Alignment_Flags (Def_Id);
Check_Eliminated (Def_Id);
- Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
end Analyze_Full_Type_Declaration;
----------------------------------
@@ -3704,7 +3708,9 @@
end if;
<<Leave>>
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Object_Declaration;
---------------------------
@@ -3943,8 +3949,10 @@
end if;
end if;
- <<Leave>>
- Analyze_Aspect_Specifications (N, T, Aspect_Specifications (N));
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, T);
+ end if;
end Analyze_Private_Extension_Declaration;
---------------------------------
@@ -4413,7 +4421,9 @@
Check_Eliminated (Id);
<<Leave>>
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Subtype_Declaration;
--------------------------------
Index: sinfo.adb
===================================================================
--- sinfo.adb (revision 177090)
+++ sinfo.adb (working copy)
@@ -256,14 +256,6 @@
return Node3 (N);
end Array_Aggregate;
- function Aspect_Cancel
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag11 (N);
- end Aspect_Cancel;
-
function Aspect_Rep_Item
(N : Node_Id) return Node_Id is
begin
@@ -3317,14 +3309,6 @@
Set_Node3_With_Parent (N, Val);
end Set_Array_Aggregate;
- procedure Set_Aspect_Cancel
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag11 (N, Val);
- end Set_Aspect_Cancel;
-
procedure Set_Aspect_Rep_Item
(N : Node_Id; Val : Node_Id) is
begin
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 177090)
+++ sinfo.ads (working copy)
@@ -584,14 +584,6 @@
-- is used for translation of the at end handler into a normal exception
-- handler.
- -- Aspect_Cancel (Flag11-Sem)
- -- Processing of aspect specifications typically generates pragmas and
- -- attribute definition clauses that are inserted into the tree after
- -- the declaration node to get the desired aspect effect. In the case
- -- of Boolean aspects that use "=> False" to cancel the effect of an
- -- aspect (i.e. turn if off), the generated pragma has the Aspect_Cancel
- -- flag set to indicate that the pragma operates in the opposite sense.
-
-- Aspect_Rep_Item (Node2-Sem)
-- Present in N_Aspect_Specification nodes. Points to the corresponding
-- pragma/attribute definition node used to process the aspect.
@@ -2085,7 +2077,6 @@
-- From_Aspect_Specification (Flag13-Sem)
-- Is_Delayed_Aspect (Flag14-Sem)
-- Import_Interface_Present (Flag16-Sem)
- -- Aspect_Cancel (Flag11-Sem)
-- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
-- Class_Present (Flag6) set if from Aspect with 'Class
-- From_Dynamic_Predicate (Flag7-Sem) Set if Dynamic_Predicate aspect
@@ -8076,9 +8067,6 @@
function Array_Aggregate
(N : Node_Id) return Node_Id; -- Node3
- function Aspect_Cancel
- (N : Node_Id) return Boolean; -- Flag11
-
function Aspect_Rep_Item
(N : Node_Id) return Node_Id; -- Node2
@@ -9054,9 +9042,6 @@
procedure Set_Array_Aggregate
(N : Node_Id; Val : Node_Id); -- Node3
- procedure Set_Aspect_Cancel
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
procedure Set_Aspect_Rep_Item
(N : Node_Id; Val : Node_Id); -- Node2
@@ -11709,7 +11694,6 @@
pragma Inline (Alternatives);
pragma Inline (Ancestor_Part);
pragma Inline (Array_Aggregate);
- pragma Inline (Aspect_Cancel);
pragma Inline (Aspect_Rep_Item);
pragma Inline (Assignment_OK);
pragma Inline (Associated_Node);
@@ -12032,7 +12016,6 @@
pragma Inline (Set_Alternatives);
pragma Inline (Set_Ancestor_Part);
pragma Inline (Set_Array_Aggregate);
- pragma Inline (Set_Aspect_Cancel);
pragma Inline (Set_Aspect_Rep_Item);
pragma Inline (Set_Assignment_OK);
pragma Inline (Set_Associated_Node);
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb (revision 177047)
+++ sem_ch7.adb (working copy)
@@ -28,7 +28,6 @@
-- handling of private and full declarations, and the construction of dispatch
-- tables for tagged types.
-with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
@@ -763,7 +762,9 @@
-- Analye aspect specifications immediately, since we need to recognize
-- things like Pure early enough to diagnose violations during analysis.
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
-- Ada 2005 (AI-217): Check if the package has been erroneously named
-- in a limited-with clause of its own context. In this case the error
@@ -1405,7 +1406,10 @@
New_Private_Type (N, Id, N);
Set_Depends_On_Private (Id);
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Private_Type_Declaration;
----------------------------------
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb (revision 177093)
+++ sem_ch9.adb (working copy)
@@ -976,7 +976,10 @@
end if;
Generate_Reference_To_Formals (Def_Id);
- Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
end Analyze_Entry_Declaration;
---------------------------------------
@@ -1336,8 +1339,10 @@
end if;
end if;
- <<Leave>>
- Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
end Analyze_Protected_Type_Declaration;
---------------------
@@ -1806,7 +1811,10 @@
-- disastrous result.
Analyze_Protected_Type_Declaration (N);
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Single_Protected_Declaration;
-------------------------------------
@@ -1873,7 +1881,10 @@
-- disastrous result.
Analyze_Task_Type_Declaration (N);
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Single_Task_Declaration;
-----------------------
@@ -2152,7 +2163,9 @@
end if;
end if;
- Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
end Analyze_Task_Type_Declaration;
-----------------------------------
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 177086)
+++ sem_prag.adb (working copy)
@@ -270,13 +270,6 @@
Pname : constant Name_Id := Pragma_Name (N);
Prag_Id : Pragma_Id;
- Sense : constant Boolean := not Aspect_Cancel (N);
- -- Sense is True if we have the normal case of a pragma that is active
- -- and turns the corresponding aspect on. It is false only for the case
- -- of a pragma coming from an aspect which is explicitly turned off by
- -- using aspect => False. If Sense is False, the effect of the pragma
- -- is to turn the corresponding aspect off.
-
Pragma_Exit : exception;
-- This exception is used to exit pragma processing completely. It is
-- used when an error is detected, and no further processing is
@@ -2461,9 +2454,9 @@
procedure Set_Atomic (E : Entity_Id) is
begin
- Set_Is_Atomic (E, Sense);
+ Set_Is_Atomic (E);
- if Sense and then not Has_Alignment_Clause (E) then
+ if not Has_Alignment_Clause (E) then
Set_Alignment (E, Uint_0);
end if;
end Set_Atomic;
@@ -2510,11 +2503,11 @@
-- Attribute belongs on the base type. If the view of the type is
-- currently private, it also belongs on the underlying type.
- Set_Is_Volatile (Base_Type (E), Sense);
- Set_Is_Volatile (Underlying_Type (E), Sense);
+ Set_Is_Volatile (Base_Type (E));
+ Set_Is_Volatile (Underlying_Type (E));
- Set_Treat_As_Volatile (E, Sense);
- Set_Treat_As_Volatile (Underlying_Type (E), Sense);
+ Set_Treat_As_Volatile (E);
+ Set_Treat_As_Volatile (Underlying_Type (E));
elsif K = N_Object_Declaration
or else (K = N_Component_Declaration
@@ -2525,7 +2518,7 @@
end if;
if Prag_Id /= Pragma_Volatile then
- Set_Is_Atomic (E, Sense);
+ Set_Is_Atomic (E);
-- If the object declaration has an explicit initialization, a
-- temporary may have to be created to hold the expression, to
@@ -2533,7 +2526,6 @@
if Nkind (Parent (E)) = N_Object_Declaration
and then Present (Expression (Parent (E)))
- and then Sense
then
Set_Has_Delayed_Freeze (E);
end if;
@@ -2554,7 +2546,7 @@
Get_Source_File_Index (Sloc (E)) =
Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
then
- Set_Is_Atomic (Underlying_Type (Etype (E)), Sense);
+ Set_Is_Atomic (Underlying_Type (Etype (E)));
end if;
end if;
@@ -4155,7 +4147,10 @@
Subp_Id : Node_Id;
Subp : Entity_Id;
Applies : Boolean;
+
Effective : Boolean := False;
+ -- Set True if inline has some effect, i.e. if there is at least one
+ -- subprogram set as inlined as a result of the use of the pragma.
procedure Make_Inline (Subp : Entity_Id);
-- Subp is the defining unit name of the subprogram declaration. Set
@@ -4299,11 +4294,6 @@
-- entity (if declared in the same unit) is inlined.
if Is_Subprogram (Subp) then
-
- if not Sense then
- return;
- end if;
-
Inner_Subp := Ultimate_Alias (Inner_Subp);
if In_Same_Source_Unit (Subp, Inner_Subp) then
@@ -4364,16 +4354,16 @@
procedure Set_Inline_Flags (Subp : Entity_Id) is
begin
if Active then
- Set_Is_Inlined (Subp, Sense);
+ Set_Is_Inlined (Subp);
end if;
if not Has_Pragma_Inline (Subp) then
- Set_Has_Pragma_Inline (Subp, Sense);
+ Set_Has_Pragma_Inline (Subp);
Effective := True;
end if;
if Prag_Id = Pragma_Inline_Always then
- Set_Has_Pragma_Inline_Always (Subp, Sense);
+ Set_Has_Pragma_Inline_Always (Subp);
end if;
end Set_Inline_Flags;
@@ -5846,12 +5836,7 @@
-- Now set appropriate Ada mode
- if Sense then
- Ada_Version := Ada_2005;
- else
- Ada_Version := Ada_Version_Default;
- end if;
-
+ Ada_Version := Ada_2005;
Ada_Version_Explicit := Ada_2005;
end if;
end;
@@ -5899,12 +5884,7 @@
-- Now set appropriate Ada mode
- if Sense then
- Ada_Version := Ada_2012;
- else
- Ada_Version := Ada_Version_Default;
- end if;
-
+ Ada_Version := Ada_2012;
Ada_Version_Explicit := Ada_2012;
end if;
end;
@@ -6378,10 +6358,10 @@
E := Base_Type (E);
end if;
- Set_Has_Volatile_Components (E, Sense);
+ Set_Has_Volatile_Components (E);
if Prag_Id = Pragma_Atomic_Components then
- Set_Has_Atomic_Components (E, Sense);
+ Set_Has_Atomic_Components (E);
end if;
else
@@ -7398,7 +7378,7 @@
-- defined in the current declarative part, and recursively
-- to any nested scope.
- Set_Discard_Names (Current_Scope, Sense);
+ Set_Discard_Names (Current_Scope);
return;
else
@@ -7419,7 +7399,7 @@
(Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
or else Ekind (E) = E_Exception
then
- Set_Discard_Names (E, Sense);
+ Set_Discard_Names (E);
else
Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1);
@@ -8256,9 +8236,7 @@
-- subtype), set the flag on that type.
if Is_Access_Subprogram_Type (Named_Entity) then
- if Sense then
- Set_Can_Use_Internal_Rep (Named_Entity, False);
- end if;
+ Set_Can_Use_Internal_Rep (Named_Entity, False);
-- Otherwise it's an error (name denotes the wrong sort of entity)
@@ -10928,43 +10906,11 @@
else
if not Ignore then
- Set_Is_Packed (Base_Type (Typ), Sense);
- Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
+ Set_Is_Packed (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
end if;
- Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
-
- -- Complete reset action for Aspect_Cancel case
-
- if Sense = False then
-
- -- Cancel size unless explicitly set
-
- if not Has_Size_Clause (Typ)
- and then not Has_Object_Size_Clause (Typ)
- then
- Set_Esize (Typ, Uint_0);
- Set_RM_Size (Typ, Uint_0);
- Set_Alignment (Typ, Uint_0);
- Set_Packed_Array_Type (Typ, Empty);
- end if;
-
- -- Reset component size unless explicitly set
-
- if not Has_Component_Size_Clause (Typ) then
- if Known_Static_Esize (Ctyp)
- and then Known_Static_RM_Size (Ctyp)
- and then Esize (Ctyp) = RM_Size (Ctyp)
- and then Addressable (Esize (Ctyp))
- then
- Set_Component_Size
- (Base_Type (Typ), Esize (Ctyp));
- else
- Set_Component_Size
- (Base_Type (Typ), Uint_0);
- end if;
- end if;
- end if;
+ Set_Has_Pragma_Pack (Base_Type (Typ));
end if;
end if;
@@ -10985,23 +10931,9 @@
-- Normal case of pack request active
else
- Set_Is_Packed (Base_Type (Typ), Sense);
- Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
- Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
-
- -- Complete reset action for Aspect_Cancel case
-
- if Sense = False then
-
- -- Cancel size if not explicitly given
-
- if not Has_Size_Clause (Typ)
- and then not Has_Object_Size_Clause (Typ)
- then
- Set_Esize (Typ, Uint_0);
- Set_Alignment (Typ, Uint_0);
- end if;
- end if;
+ Set_Is_Packed (Base_Type (Typ));
+ Set_Has_Pragma_Pack (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
end if;
end if;
end if;
@@ -11145,13 +11077,11 @@
Check_Duplicate_Pragma (Ent);
- if Sense then
- Prag :=
- Make_Linker_Section_Pragma
- (Ent, Sloc (N), ".persistent.bss");
- Insert_After (N, Prag);
- Analyze (Prag);
- end if;
+ Prag :=
+ Make_Linker_Section_Pragma
+ (Ent, Sloc (N), ".persistent.bss");
+ Insert_After (N, Prag);
+ Analyze (Prag);
-- Case of use as configuration pragma with no arguments
@@ -11310,11 +11240,11 @@
if Present (Ent)
and then not (Pk = N_Package_Specification
- and then Present (Generic_Parent (Pa)))
+ and then Present (Generic_Parent (Pa)))
then
if not Debug_Flag_U then
- Set_Is_Preelaborated (Ent, Sense);
- Set_Suppress_Elaboration_Warnings (Ent, Sense);
+ Set_Is_Preelaborated (Ent);
+ Set_Suppress_Elaboration_Warnings (Ent);
end if;
end if;
end Preelaborate;
@@ -11897,11 +11827,11 @@
("pragma% requires a function name", Arg1);
end if;
- Set_Is_Pure (Def_Id, Sense);
+ Set_Is_Pure (Def_Id);
if not Has_Pragma_Pure_Function (Def_Id) then
- Set_Has_Pragma_Pure_Function (Def_Id, Sense);
- Effective := Sense;
+ Set_Has_Pragma_Pure_Function (Def_Id);
+ Effective := True;
end if;
exit when From_Aspect_Specification (N);
@@ -11909,7 +11839,7 @@
exit when No (E) or else Scope (E) /= Current_Scope;
end loop;
- if Sense and then not Effective
+ if not Effective
and then Warn_On_Redundant_Constructs
then
Error_Msg_NE
@@ -12685,7 +12615,7 @@
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)), Sense);
+ Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
----------------------------------
-- Suppress_Exception_Locations --
@@ -13129,14 +13059,10 @@
end loop;
end if;
- Set_Is_Unchecked_Union (Typ, Sense);
-
- if Sense then
- Set_Convention (Typ, Convention_C);
- end if;
-
- Set_Has_Unchecked_Union (Base_Type (Typ), Sense);
- Set_Is_Unchecked_Union (Base_Type (Typ), Sense);
+ Set_Is_Unchecked_Union (Typ);
+ Set_Convention (Typ, Convention_C);
+ Set_Has_Unchecked_Union (Base_Type (Typ));
+ Set_Is_Unchecked_Union (Base_Type (Typ));
end Unchecked_Union;
------------------------
@@ -13195,7 +13121,7 @@
Error_Pragma_Arg ("pragma% requires type", Arg1);
end if;
- Set_Universal_Aliasing (Implementation_Base_Type (E_Id), Sense);
+ Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
end Universal_Alias;
--------------------
@@ -13263,7 +13189,7 @@
("pragma% can only be applied to a variable",
Arg_Expr);
else
- Set_Has_Pragma_Unmodified (Arg_Ent, Sense);
+ Set_Has_Pragma_Unmodified (Arg_Ent);
end if;
end if;
@@ -13358,7 +13284,7 @@
Generate_Reference (Arg_Ent, N);
end if;
- Set_Has_Pragma_Unreferenced (Arg_Ent, Sense);
+ Set_Has_Pragma_Unreferenced (Arg_Ent);
end if;
Next (Arg_Node);
@@ -13393,7 +13319,7 @@
("argument for pragma% must be type or subtype", Arg_Node);
end if;
- Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr), Sense);
+ Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
Next (Arg_Node);
end loop;
end Unreferenced_Objects;
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb (revision 177027)
+++ sem_ch12.adb (working copy)
@@ -1925,7 +1925,9 @@
end if;
end if;
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Formal_Object_Declaration;
----------------------------------------------
@@ -2280,8 +2282,10 @@
Set_Scope (Pack_Id, Scope (Formal));
Set_Has_Completion (Pack_Id, True);
- <<Leave>>
- Analyze_Aspect_Specifications (N, Pack_Id, Aspect_Specifications (N));
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Pack_Id);
+ end if;
end Analyze_Formal_Package_Declaration;
---------------------------------
@@ -2501,8 +2505,11 @@
end if;
end if;
- <<Leave>>
- Analyze_Aspect_Specifications (N, Nam, Aspect_Specifications (N));
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Nam);
+ end if;
+
end Analyze_Formal_Subprogram_Declaration;
-------------------------------------
@@ -2576,7 +2583,10 @@
end case;
Set_Is_Generic_Type (T);
- Analyze_Aspect_Specifications (N, T, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, T);
+ end if;
end Analyze_Formal_Type_Declaration;
------------------------------------
@@ -2754,7 +2764,9 @@
end if;
end if;
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Generic_Package_Declaration;
--------------------------------------------
@@ -2882,7 +2894,10 @@
Generate_Reference_To_Formals (Id);
List_Inherited_Pre_Post_Aspects (Id);
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Generic_Subprogram_Declaration;
-----------------------------------
@@ -3556,9 +3571,10 @@
Set_Defining_Identifier (N, Act_Decl_Id);
end if;
- <<Leave>>
- Analyze_Aspect_Specifications
- (N, Act_Decl_Id, Aspect_Specifications (N));
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Act_Decl_Id);
+ end if;
exception
when Instantiation_Error =>
@@ -4336,9 +4352,10 @@
Generic_Renamings_HTable.Reset;
end if;
- <<Leave>>
- Analyze_Aspect_Specifications
- (N, Act_Decl_Id, Aspect_Specifications (N));
+ <<Leave>>
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Act_Decl_Id);
+ end if;
exception
when Instantiation_Error =>
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 177093)
+++ sem_ch6.adb (working copy)
@@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -263,7 +262,10 @@
Generate_Reference_To_Formals (Designator);
Check_Eliminated (Designator);
- Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Designator);
+ end if;
end Analyze_Abstract_Subprogram_Declaration;
---------------------------------
@@ -3067,7 +3069,10 @@
end if;
List_Inherited_Pre_Post_Aspects (Designator);
- Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Designator);
+ end if;
end Analyze_Subprogram_Declaration;
--------------------------------------
Index: sem_ch11.adb
===================================================================
--- sem_ch11.adb (revision 177056)
+++ sem_ch11.adb (working copy)
@@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
@@ -65,7 +64,10 @@
Set_Etype (Id, Standard_Exception_Type);
Set_Is_Statically_Allocated (Id);
Set_Is_Pure (Id, PF);
- Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, Id);
+ end if;
end Analyze_Exception_Declaration;
--------------------------------
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 177094)
+++ sem_ch13.adb (working copy)
@@ -78,16 +78,6 @@
-- inherited from a derived type that is no longer appropriate for the
-- new Esize value. In this case, we reset the Alignment to unknown.
- procedure Analyze_Non_Null_Aspect_Specifications
- (N : Node_Id;
- E : Entity_Id;
- L : List_Id);
- -- This procedure is called to analyze aspect specifications for node N.
- -- E is the corresponding entity declared by the declaration node N, and
- -- L is the list of aspect specifications for this node. This procedure
- -- does the real work, as opposed to Analyze_Aspect_Specifications which
- -- is inlined to fast-track the common case.
-
procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ,
-- then either there are pragma Invariant entries on the rep chain for the
@@ -693,34 +683,13 @@
-- Analyze_Aspect_Specifications --
-----------------------------------
- procedure Analyze_Aspect_Specifications
- (N : Node_Id;
- E : Entity_Id;
- L : List_Id)
- is
- begin
- -- Return if no aspects
-
- if L = No_List then
- return;
- end if;
-
- Analyze_Non_Null_Aspect_Specifications (N, E, L);
- end Analyze_Aspect_Specifications;
-
- --------------------------------------------
- -- Analyze_Non_Null_Aspect_Specifications --
- --------------------------------------------
-
- procedure Analyze_Non_Null_Aspect_Specifications
- (N : Node_Id;
- E : Entity_Id;
- L : List_Id)
- is
+ procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is
Aspect : Node_Id;
Aitem : Node_Id;
Ent : Node_Id;
+ L : constant List_Id := Aspect_Specifications (N);
+
Ins_Node : Node_Id := N;
-- Insert pragmas (except Pre/Post/Invariant/Predicate) after this node
@@ -744,10 +713,12 @@
-- Set True if delay is required
begin
+ pragma Assert (Present (L));
+
-- Loop through aspects
Aspect := First (L);
- while Present (Aspect) loop
+ Aspect_Loop : while Present (Aspect) loop
declare
Loc : constant Source_Ptr := Sloc (Aspect);
Id : constant Node_Id := Identifier (Aspect);
@@ -759,6 +730,72 @@
Eloc : Source_Ptr := Sloc (Expr);
-- Source location of expression, modified when we split PPC's
+ procedure Check_False_Aspect_For_Derived_Type;
+ -- This procedure checks for the case of a false aspect for a
+ -- derived type, which improperly tries to cancel an aspect
+ -- inherited from the parent;
+
+ -----------------------------------------
+ -- Check_False_Aspect_For_Derived_Type --
+ -----------------------------------------
+
+ procedure Check_False_Aspect_For_Derived_Type is
+ begin
+ -- We are only checking derived types
+
+ if not Is_Derived_Type (E) then
+ return;
+ end if;
+
+ case A_Id is
+ when Aspect_Atomic | Aspect_Shared =>
+ if not Is_Atomic (E) then
+ return;
+ end if;
+
+ when Aspect_Atomic_Components =>
+ if not Has_Atomic_Components (E) then
+ return;
+ end if;
+
+ when Aspect_Discard_Names =>
+ if not Discard_Names (E) then
+ return;
+ end if;
+
+ when Aspect_Pack =>
+ if not Is_Packed (E) then
+ return;
+ end if;
+
+ when Aspect_Unchecked_Union =>
+ if not Is_Unchecked_Union (E) then
+ return;
+ end if;
+
+ when Aspect_Volatile =>
+ if not Is_Volatile (E) then
+ return;
+ end if;
+
+ when Aspect_Volatile_Components =>
+ if not Has_Volatile_Components (E) then
+ return;
+ end if;
+
+ when others =>
+ return;
+ end case;
+
+ -- Fall through means we are canceling an inherited aspect
+
+ Error_Msg_Name_1 := Nam;
+ Error_Msg_NE
+ ("derived type& inherits aspect%, cannot cancel", Expr, E);
+ end Check_False_Aspect_For_Derived_Type;
+
+ -- Start of processing for Aspect_Loop
+
begin
-- Skip aspect if already analyzed (not clear if this is needed)
@@ -837,39 +874,37 @@
raise Program_Error;
-- Aspects taking an optional boolean argument. For all of
- -- these we just create a matching pragma and insert it. When
- -- the aspect is processed to insert the pragma, the expression
- -- is analyzed, setting Cancel_Aspect if the value is False.
+ -- these we just create a matching pragma and insert it, if
+ -- the expression is missing or set to True. If the expression
+ -- is False, we can ignore the aspect with the exception that
+ -- in the case of a derived type, we must check for an illegal
+ -- attempt to cancel an inherited aspect.
when Boolean_Aspects =>
Set_Is_Boolean_Aspect (Aspect);
- -- Build corresponding pragma node
+ if Present (Expr)
+ and then Is_False (Static_Boolean (Expr))
+ then
+ Check_False_Aspect_For_Derived_Type;
+ goto Continue;
+ end if;
+ -- If True, build corresponding pragma node
+
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations => New_List (Ent),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
- -- No delay required if no expression (nothing to delay!)
+ -- Never need to delay for boolean aspects
- if No (Expr) then
- Delay_Required := False;
+ Delay_Required := False;
- -- Expression is present, delay is required. Note that
- -- even if the expression is "True", some idiot might
- -- define True as False before the freeze point!
-
- else
- Delay_Required := True;
- Set_Is_Delayed_Aspect (Aspect);
- end if;
-
-- Library unit aspects. These are boolean aspects, but we
- -- always evaluate the expression right away if it is present
- -- and just ignore the aspect if the expression is False. We
- -- never delay expression evaluation in this case.
+ -- have to do special things with the insertion, since the
+ -- pragma belongs inside the declarations of a package.
when Library_Unit_Aspects =>
if Present (Expr)
@@ -1220,8 +1255,8 @@
<<Continue>>
Next (Aspect);
- end loop;
- end Analyze_Non_Null_Aspect_Specifications;
+ end loop Aspect_Loop;
+ end Analyze_Aspect_Specifications;
-----------------------
-- Analyze_At_Clause --
Index: sem_ch13.ads
===================================================================
--- sem_ch13.ads (revision 177094)
+++ sem_ch13.ads (working copy)
@@ -36,17 +36,10 @@
procedure Analyze_Record_Representation_Clause (N : Node_Id);
procedure Analyze_Code_Statement (N : Node_Id);
- procedure Analyze_Aspect_Specifications
- (N : Node_Id;
- E : Entity_Id;
- L : List_Id);
- -- This procedure is called to analyze aspect specifications for node N.
- -- E is the corresponding entity declared by the declaration node N, and
- -- L is the list of aspect specifications for this node. If L is No_List,
- -- the call is ignored. Note that we can't use a simpler interface of just
- -- passing the node N, since the analysis of the node may cause it to be
- -- rewritten to a node not permitting aspect specifications.
- pragma Inline (Analyze_Aspect_Specifications);
+ procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id);
+ -- This procedure is called to analyze aspect specifications for node N. E
+ -- is the corresponding entity declared by the declaration node N. Callers
+ -- should check that Has_Aspects (N) is True before calling this routine.
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id);
-- Called from Freeze where R is a record entity for which reverse bit
