diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/ada/a-calend.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 105 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/prepcomp.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/prj-tree.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/prj.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/s-imgrea.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/scng.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 64 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 3 |
15 files changed, 163 insertions, 73 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 91aadda..86e43ef 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +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): diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb index f5076f2..b0fba5d 100644 --- a/gcc/ada/a-calend.adb +++ b/gcc/ada/a-calend.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 01144f5..5fcb6c8 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -558,7 +558,7 @@ package body Debug is -- 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). diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index e3f3f70..845b7a3 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1019,13 +1019,11 @@ package body Exp_Attr is -- 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; @@ -1048,10 +1046,10 @@ package body Exp_Attr is 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; @@ -1350,49 +1348,68 @@ package body Exp_Attr is -- 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 @@ -1418,8 +1435,8 @@ package body Exp_Attr is -- 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); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 1a57074..9ef851d 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -101,6 +101,11 @@ package Opt is -- 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 -- ---------------------------------------------- @@ -117,7 +122,7 @@ package Opt is -- 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. diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index af2ed87..b454af4 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -2798,7 +2798,7 @@ package body Ch4 is 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; diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb index 549d7f8..cffb0ce 100644 --- a/gcc/ada/prepcomp.adb +++ b/gcc/ada/prepcomp.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index a36e9f9..f2290bb 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 2b20f6a..8920890 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- diff --git a/gcc/ada/s-imgrea.adb b/gcc/ada/s-imgrea.adb index 3847c54..62ec93a 100644 --- a/gcc/ada/s-imgrea.adb +++ b/gcc/ada/s-imgrea.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 6c9cab7..0fae960 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -1612,7 +1612,7 @@ package body Scng is end if; when '@' => - if not Extensions_Allowed then + if Ada_Version < Ada_2020 then Error_Illegal_Character; Scan_Ptr := Scan_Ptr + 1; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 5c244ee..bb719d3 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4295,13 +4295,13 @@ package body Sem_Attr is -- 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 @@ -4419,7 +4419,7 @@ package body Sem_Attr is 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 @@ -4431,14 +4431,14 @@ package body Sem_Attr is 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; @@ -4467,7 +4467,7 @@ package body Sem_Attr is then null; - elsif No (Enclosing_Pragma) then + elsif No (Encl_Prag) then Error_Attr ("attribute% must appear within appropriate pragma", N); end if; @@ -4504,8 +4504,8 @@ package body Sem_Attr is 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 " @@ -4521,9 +4521,7 @@ package body Sem_Attr is -- 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); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 9956814..7c62787 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -81,7 +81,7 @@ package body Sem_Ch13 is ----------------------- 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); @@ -364,9 +364,9 @@ package body Sem_Ch13 is 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. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 694e112..5958d42 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9118,6 +9118,10 @@ package body Sem_Util is (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 @@ -9125,6 +9129,44 @@ package body Sem_Util is -- 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 -- -------------------------------- @@ -9302,7 +9344,19 @@ package body Sem_Util is -- 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; @@ -9321,6 +9375,14 @@ package body Sem_Util is 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. diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 4aac847..176dbe4 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -1502,6 +1502,9 @@ package body Switch.C is 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; |