+2017-01-23 Yannick Moy <moy@adacore.com>
+
+ * sem_util.adb (Has_Enabled_Property): Treat
+ protected objects and variables differently from other variables.
+
2017-01-23 Thomas Quinot <quinot@adacore.com>
* sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order):
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- d.o Conservative elaboration order for indirect calls. This causes
-- P'Access to be treated as a call in more cases.
- -- d.p In Ada 95 (or 83) mode, use original Ada 95 behaviour for the
+ -- d.p In Ada 95 (or 83) mode, use original Ada 95 behavior for the
-- interpretation of component clauses crossing byte boundaries when
-- using the non-default bit order (i.e. ignore AI95-0133).
-- Local variables
- Exprs : constant List_Id := Expressions (N);
Pref : constant Node_Id := Prefix (N);
- Typ : constant Entity_Id := Etype (Pref);
+ Base_Typ : constant Entity_Id := Base_Type (Etype (Pref));
+ Exprs : constant List_Id := Expressions (N);
+ Aux_Decl : Node_Id;
Blk : Node_Id;
- CW_Decl : Node_Id;
- CW_Temp : Entity_Id;
- CW_Typ : Entity_Id;
Decls : List_Id;
Installed : Boolean;
Loc : Source_Ptr;
Loop_Id := Entity (First (Exprs));
Loop_Stmt := Label_Construct (Parent (Loop_Id));
- -- Climb the parent chain to find the nearest enclosing loop. Skip all
- -- internally generated loops for quantified expressions and for
- -- element iterators over multidimensional arrays: pragma applies to
- -- source loop.
+ -- Climb the parent chain to find the nearest enclosing loop. Skip
+ -- all internally generated loops for quantified expressions and for
+ -- element iterators over multidimensional arrays because the pragma
+ -- applies to source loop.
else
Loop_Stmt := N;
-- Preserve the tag of the prefix by offering a specific view of the
-- class-wide version of the prefix.
- if Is_Tagged_Type (Typ) then
+ if Is_Tagged_Type (Base_Typ) then
+ Tagged_Case : declare
+ CW_Temp : Entity_Id;
+ CW_Typ : Entity_Id;
- -- Generate:
- -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
+ begin
+ -- Generate:
+ -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
- CW_Temp := Make_Temporary (Loc, 'T');
- CW_Typ := Class_Wide_Type (Typ);
+ CW_Temp := Make_Temporary (Loc, 'T');
+ CW_Typ := Class_Wide_Type (Base_Typ);
- CW_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => CW_Temp,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
- Expression =>
- Convert_To (CW_Typ, Relocate_Node (Pref)));
- Append_To (Decls, CW_Decl);
+ Aux_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => CW_Temp,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
+ Expression =>
+ Convert_To (CW_Typ, Relocate_Node (Pref)));
+ Append_To (Decls, Aux_Decl);
- -- Generate:
- -- Temp : Typ renames Typ (CW_Temp);
+ -- Generate:
+ -- Temp : Base_Typ renames Base_Typ (CW_Temp);
- Temp_Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Name =>
- Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)));
- Append_To (Decls, Temp_Decl);
+ Temp_Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Subtype_Mark => New_Occurrence_Of (Base_Typ, Loc),
+ Name =>
+ Convert_To (Base_Typ, New_Occurrence_Of (CW_Temp, Loc)));
+ Append_To (Decls, Temp_Decl);
+ end Tagged_Case;
- -- Non-tagged case
+ -- Untagged case
else
- CW_Decl := Empty;
+ Untagged_Case : declare
+ Temp_Expr : Node_Id;
- -- Generate:
- -- Temp : constant Typ := Pref;
+ begin
+ Aux_Decl := Empty;
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression => Relocate_Node (Pref));
- Append_To (Decls, Temp_Decl);
+ -- Generate a nominal type for the constant when the prefix is of
+ -- a constrained type. This is achieved by setting the Etype of
+ -- the relocated prefix to its base type. Since the prefix is now
+ -- the initialization expression of the constant, its freezing
+ -- will produce a proper nominal type.
+
+ Temp_Expr := Relocate_Node (Pref);
+ Set_Etype (Temp_Expr, Base_Typ);
+
+ -- Generate:
+ -- Temp : constant Base_Typ := Pref;
+
+ Temp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Base_Typ, Loc),
+ Expression => Temp_Expr);
+ Append_To (Decls, Temp_Decl);
+ end Untagged_Case;
end if;
-- Step 4: Analyze all bits
-- the declaration of the constant.
else
- if Present (CW_Decl) then
- Analyze (CW_Decl);
+ if Present (Aux_Decl) then
+ Analyze (Aux_Decl);
end if;
Analyze (Temp_Decl);
-- GPRBUILD
-- Set to True by gprbuild when the version of GNAT is 5.03 or before.
+ Checksum_Accumulate_Limited_Checksum : Boolean := False;
+ -- Used to control the computation of the limited view of a package.
+ -- (Not currently used, possible optimization for ALI files of units
+ -- in limited with_clauses).
+
----------------------------------------------
-- Settings of Modes for Current Processing --
----------------------------------------------
-- trying to specify other values will be ignored (in case of pragma
-- Ada_xxx) or generate an error (in case of -gnat83/95/xx switches).
- type Ada_Version_Type is (Ada_83, Ada_95, Ada_2005, Ada_2012);
+ type Ada_Version_Type is (Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2020);
pragma Ordered (Ada_Version_Type);
-- Versions of Ada for Ada_Version below. Note that these are ordered,
-- so that tests like Ada_Version >= Ada_95 are legitimate and useful.
Scan; -- past minus
when Tok_At_Sign => -- AI12-0125 : target_name
- if not Extensions_Allowed then
+ if Ada_Version < Ada_2020 then
Error_Msg_SC ("target name is an Ada 2020 extension");
Error_Msg_SC ("\compile with -gnatX");
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
end if;
when '@' =>
- if not Extensions_Allowed then
+ if Ada_Version < Ada_2020 then
Error_Illegal_Character;
Scan_Ptr := Scan_Ptr + 1;
-- Local variables
- Context : constant Node_Id := Parent (N);
- Attr : Node_Id;
- Enclosing_Loop : Node_Id;
- Loop_Id : Entity_Id := Empty;
- Scop : Entity_Id;
- Stmt : Node_Id;
- Enclosing_Pragma : Node_Id := Empty;
+ Context : constant Node_Id := Parent (N);
+ Attr : Node_Id;
+ Encl_Loop : Node_Id;
+ Encl_Prag : Node_Id := Empty;
+ Loop_Id : Entity_Id := Empty;
+ Scop : Entity_Id;
+ Stmt : Node_Id;
-- Start of processing for Loop_Entry
Name_Assert_And_Cut,
Name_Assume)
then
- Enclosing_Pragma := Original_Node (Stmt);
+ Encl_Prag := Original_Node (Stmt);
-- Locate the enclosing loop (if any). Note that Ada 2012 array
-- iteration may be expanded into several nested loops, we are
and then Comes_From_Source (Original_Node (Stmt))
and then Nkind (Original_Node (Stmt)) = N_Loop_Statement
then
- Enclosing_Loop := Stmt;
+ Encl_Loop := Stmt;
-- The original attribute reference may lack a loop name. Use
-- the name of the enclosing loop because it is the related
-- loop.
if No (Loop_Id) then
- Loop_Id := Entity (Identifier (Enclosing_Loop));
+ Loop_Id := Entity (Identifier (Encl_Loop));
end if;
exit;
then
null;
- elsif No (Enclosing_Pragma) then
+ elsif No (Encl_Prag) then
Error_Attr ("attribute% must appear within appropriate pragma", N);
end if;
then
null;
- elsif Present (Enclosing_Loop)
- and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id
+ elsif Present (Encl_Loop)
+ and then Entity (Identifier (Encl_Loop)) /= Loop_Id
then
Error_Attr_P
("prefix of attribute % that applies to outer loop must denote "
-- early transformation also avoids the generation of a useless loop
-- entry constant.
- if Present (Enclosing_Pragma)
- and then Is_Ignored (Enclosing_Pragma)
- then
+ if Present (Encl_Prag) and then Is_Ignored (Encl_Prag) then
Rewrite (N, Relocate_Node (P));
Preanalyze_And_Resolve (N);
-----------------------
procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R : Entity_Id);
- -- Helper routine providing the original (pre-AI95-0133) behaviour for
+ -- Helper routine providing the original (pre-AI95-0133) behavior for
-- Adjust_Record_For_Reverse_Bit_Order.
procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint);
SSU : constant Uint := UI_From_Int (System_Storage_Unit);
begin
- -- Processing here used to depend on Ada version: the behaviour was
+ -- Processing here used to depend on Ada version: the behavior was
-- changed by AI95-0133. However this AI is a Binding interpretation,
- -- so we now implement it even in Ada 95 mode. The original behaviour
+ -- so we now implement it even in Ada 95 mode. The original behavior
-- from unamended Ada 95 is still available for compatibility under
-- debugging switch -gnatd.
(Item_Id : Entity_Id;
Property : Name_Id) return Boolean
is
+ function Protected_Object_Has_Enabled_Property return Boolean;
+ -- Determine whether a protected object denoted by Item_Id has the
+ -- property enabled.
+
function State_Has_Enabled_Property return Boolean;
-- Determine whether a state denoted by Item_Id has the property enabled
-- Determine whether a variable denoted by Item_Id has the property
-- enabled.
+ -------------------------------------------
+ -- Protected_Object_Has_Enabled_Property --
+ -------------------------------------------
+
+ function Protected_Object_Has_Enabled_Property return Boolean is
+ Constits : constant Elist_Id := Part_Of_Constituents (Item_Id);
+ Constit_Elmt : Elmt_Id;
+ Constit_Id : Entity_Id;
+
+ begin
+ -- Protected objects always have the properties Async_Readers and
+ -- Async_Writers. (SPARK RM 7.1.2(16))
+
+ if Property = Name_Async_Readers
+ or else Property = Name_Async_Writers
+ then
+ return True;
+
+ -- Protected objects that have Part_Of components also inherit
+ -- their properties Effective_Reads and Effective_Writes. (SPARK
+ -- RM 7.1.2(16))
+
+ elsif Present (Constits) then
+ Constit_Elmt := First_Elmt (Constits);
+ while Present (Constit_Elmt) loop
+ Constit_Id := Node (Constit_Elmt);
+
+ if Has_Enabled_Property (Constit_Id, Property) then
+ return True;
+ end if;
+
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
+
+ return False;
+ end Protected_Object_Has_Enabled_Property;
+
--------------------------------
-- State_Has_Enabled_Property --
--------------------------------
-- The implicit case lacks all property pragmas
elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
- return True;
+
+ -- A variable of a protected type only has the properties
+ -- Async_Readers and Async_Writers. It cannot have Part_Of
+ -- components (only protected objects can), hence it cannot
+ -- inherit their properties Effective_Reads and Effective_Writes.
+ -- (SPARK RM 7.1.2(16))
+
+ if Is_Protected_Type (Etype (Item_Id)) then
+ return Property = Name_Async_Readers
+ or else Property = Name_Async_Writers;
+ else
+ return True;
+ end if;
else
return False;
elsif Ekind (Item_Id) = E_Variable then
return Variable_Has_Enabled_Property;
+ -- By default, protected objects only have the properties Async_Readers
+ -- and Async_Writers. If they have Part_Of components, they also inherit
+ -- their properties Effective_Reads and Effective_Writes. (SPARK RM
+ -- 7.1.2(16))
+
+ elsif Ekind (Item_Id) = E_Protected_Object then
+ return Protected_Object_Has_Enabled_Property;
+
-- Otherwise a property is enabled when the related item is effectively
-- volatile.
elsif Switch_Chars (Ptr .. Ptr + 3) = "2012" then
Ada_Version := Ada_2012;
+ elsif Switch_Chars (Ptr .. Ptr + 3) = "2020" then
+ Ada_Version := Ada_2020;
+
else
Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Ptr + 3));
end if;
projects / gcc.git / commitdiff