diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 33 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 14 | ||||
| -rw-r--r-- | gcc/ada/impunit.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/s-atocou.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/s-expmod.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/s-vallli.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/s-valuti.ads | 28 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 168 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 5 |
11 files changed, 196 insertions, 123 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index df07e44..b407571 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2014-10-17 Robert Dewar <dewar@adacore.com> + + * sem_util.adb: Minor reformatting. + +2014-10-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Build_Function_Wrapper): Build wrappers for + actuals that are defaulted subprograms of the formal subprogram + declaration. + +2014-10-17 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb (Expand_N_Op_Eq): Make sure we deal with the + implementation base type. + * sinfo.ads: Add a note for N_Op_Eq and N_Op_Ne that record + operands are always expanded out into component comparisons. + +2014-10-17 Robert Dewar <dewar@adacore.com> + + * s-vallli.adb: Minor comment correction. + * s-valuti.ads: Minor comment reformatting. + +2014-10-17 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi: Document System.Atomic_Counters. + * impunit.adb: Add System.Atomic_Counters (s-atocou.ads) to the + list of user- accessible units added as children of System. + * s-atocou.ads: Update comment. + +2014-10-17 Arnaud Charlet <charlet@adacore.com> + + * s-expmod.ads: Add comments. + 2014-10-17 Hristian Kirtchev <kirtchev@adacore.com> * sem_ch3.adb (Build_Derived_Record_Type): Remove the propagation diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 9068fdc..5fdba53 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7152,7 +7152,10 @@ package body Exp_Ch4 is return; end if; - Typl := Base_Type (Typl); + -- Now get the implementation base type (note that plain Base_Type here + -- might lead us back to the private type, which is not what we want!) + + Typl := Implementation_Base_Type (Typl); -- Equality between variant records results in a call to a routine -- that has conditional tests of the discriminant value(s), and hence diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index b0bed4b..4258722 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -661,6 +661,7 @@ The GNAT Library * Interfaces.VxWorks.IO (i-vxwoio.ads):: * System.Address_Image (s-addima.ads):: * System.Assertions (s-assert.ads):: +* System.Atomic_Counters (s-atocou.ads):: * System.Memory (s-memory.ads):: * System.Multiprocessors (s-multip.ads):: * System.Multiprocessors.Dispatching_Domains (s-mudido.ads):: @@ -19074,6 +19075,7 @@ of GNAT, and will generate a warning message. * Interfaces.VxWorks.IO (i-vxwoio.ads):: * System.Address_Image (s-addima.ads):: * System.Assertions (s-assert.ads):: +* System.Atomic_Counters (s-atocou.ads):: * System.Memory (s-memory.ads):: * System.Multiprocessors (s-multip.ads):: * System.Multiprocessors.Dispatching_Domains (s-mudido.ads):: @@ -20585,6 +20587,18 @@ This package provides the declaration of the exception raised by an run-time assertion failure, as well as the routine that is used internally to raise this assertion. +@node System.Atomic_Counters (s-atocou.ads) +@section @code{System.Atomic_Counters} (@file{s-atocou.ads}) +@cindex @code{System.Atomic_Counters} (@file{s-atocou.ads}) + +@noindent +This package provides the declaration of an atomic counter type, +together with efficient routines (using hardware +synchronization primitives) for incrementing, decrementing, +and testing of these counters. This package is implemented +on most targets, including all Alpha, ia64, PowerPC, SPARC V9, +x86, and x86_64 platforms. + @node System.Memory (s-memory.ads) @section @code{System.Memory} (@file{s-memory.ads}) @cindex @code{System.Memory} (@file{s-memory.ads}) diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 69356cb..49baf16 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -367,6 +367,7 @@ package body Impunit is -------------------------------------- ("s-addima", F), -- System.Address_Image + ("s-atocou", F), -- System.Atomic_Counters ("s-assert", F), -- System.Assertions ("s-diflio", F), -- System.Dim.Float_IO ("s-diinio", F), -- System.Dim.Integer_IO diff --git a/gcc/ada/s-atocou.ads b/gcc/ada/s-atocou.ads index 55d6bf0..a2e6d89 100644 --- a/gcc/ada/s-atocou.ads +++ b/gcc/ada/s-atocou.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2014, 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- -- @@ -37,8 +37,6 @@ -- - all x86 platforms -- - all x86_64 platforms --- Why isn't this package available to application programs??? - package System.Atomic_Counters is pragma Preelaborate; @@ -59,20 +57,19 @@ package System.Atomic_Counters is function Decrement (Item : in out Atomic_Counter) return Boolean; pragma Inline_Always (Decrement); - -- Decrements value of atomic counter, returns True when value reach zero. + -- Decrements value of atomic counter, returns True when value reach zero function Is_One (Item : Atomic_Counter) return Boolean; pragma Inline_Always (Is_One); - -- Returns True when value of the atomic counter is one. + -- Returns True when value of the atomic counter is one procedure Initialize (Item : out Atomic_Counter); pragma Inline_Always (Initialize); -- Initialize counter by setting its value to one. This subprogram is - -- intended to be used in special cases when counter object can't be + -- intended to be used in special cases when the counter object cannot be -- initialized in standard way. private - type Unsigned_32 is mod 2 ** 32; type Atomic_Counter is limited record diff --git a/gcc/ada/s-expmod.ads b/gcc/ada/s-expmod.ads index 3dd118d..c906915 100644 --- a/gcc/ada/s-expmod.ads +++ b/gcc/ada/s-expmod.ads @@ -32,15 +32,25 @@ -- This function performs exponentiation of a modular type with non-binary -- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit -- accounting for the modulus value which is passed as the second argument. +-- Note that 1 is a binary modulus (2**0), so the compiler should not (and +-- will not) call this function with Modulus equal to 1). with System.Unsigned_Types; package System.Exp_Mod is pragma Pure; + use type System.Unsigned_Types.Unsigned; + + subtype Power_Of_2 is System.Unsigned_Types.Unsigned with + Dynamic_Predicate => + Power_Of_2 /= 0 and then (Power_Of_2 and (Power_Of_2 - 1)) = 0; function Exp_Modular (Left : System.Unsigned_Types.Unsigned; Modulus : System.Unsigned_Types.Unsigned; - Right : Natural) return System.Unsigned_Types.Unsigned; + Right : Natural) return System.Unsigned_Types.Unsigned + with + Pre => Modulus /= 0 and then Modulus not in Power_Of_2, + Post => Exp_Modular'Result = Left ** Right mod Modulus; end System.Exp_Mod; diff --git a/gcc/ada/s-vallli.adb b/gcc/ada/s-vallli.adb index 035a95d..203e475 100644 --- a/gcc/ada/s-vallli.adb +++ b/gcc/ada/s-vallli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -51,7 +51,7 @@ package body System.Val_LLI is -- Set to True if minus sign is present, otherwise to False Start : Positive; - -- Saves location of first non-blank (not used in this case) + -- Saves location of first non-blank begin Scan_Sign (Str, Ptr, Max, Minus, Start); diff --git a/gcc/ada/s-valuti.ads b/gcc/ada/s-valuti.ads index ce9dc3b..e69af0f 100644 --- a/gcc/ada/s-valuti.ads +++ b/gcc/ada/s-valuti.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -43,9 +43,9 @@ package System.Val_Util is F, L : out Integer); -- This procedure scans the string S setting F to be the index of the first -- non-blank character of S and L to be the index of the last non-blank - -- character of S. Any lower case characters present in S will be folded - -- to their upper case equivalent except for character literals. If S - -- consists of entirely blanks then Constraint_Error is raised. + -- character of S. Any lower case characters present in S will be folded to + -- their upper case equivalent except for character literals. If S consists + -- of entirely blanks then Constraint_Error is raised. -- -- Note: if S is the null string, F is set to S'First, L to S'Last @@ -60,25 +60,25 @@ package System.Val_Util is -- last character in the string). Scan_Sign first scans out any initial -- blanks, raising Constraint_Error if the field is all blank. It then -- checks for and skips an initial plus or minus, requiring a non-blank - -- character to follow (Constraint_Error is raised if plus or minus - -- appears at the end of the string or with a following blank). Minus is - -- set True if a minus sign was skipped, and False otherwise. On exit - -- Ptr.all points to the character after the sign, or to the first - -- non-blank character if no sign is present. Start is set to the point - -- to the first non-blank character (sign or digit after it). + -- character to follow (Constraint_Error is raised if plus or minus appears + -- at the end of the string or with a following blank). Minus is set True + -- if a minus sign was skipped, and False otherwise. On exit Ptr.all points + -- to the character after the sign, or to the first non-blank character + -- if no sign is present. Start is set to the point to the first non-blank + -- character (sign or digit after it). -- -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. Constraint_Error is - -- also raised in this case. + -- is greater than Max as required in this case. Constraint_Error is also + -- raised in this case. procedure Scan_Plus_Sign (Str : String; Ptr : not null access Integer; Max : Integer; Start : out Positive); - -- Same as Scan_Sign, but allows only plus, not minus. - -- This is used for modular types. + -- Same as Scan_Sign, but allows only plus, not minus. This is used for + -- modular types. function Scan_Exponent (Str : String; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index c9738cc..277b7ef 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1056,7 +1056,12 @@ package body Sem_Ch12 is Actuals := New_List; Profile := New_List; - F := First_Formal (Entity (Actual)); + if Present (Actual) then + F := First_Formal (Entity (Actual)); + else + F := First_Formal (Formal); + end if; + N_Parms := 0; while Present (F) loop @@ -1066,16 +1071,26 @@ package body Sem_Ch12 is New_F := Make_Temporary (Loc, Character'Val (Character'Pos ('A') + N_Parms)); - -- If a formal has a class-wide type, rewrite as the corresponding - -- attribute, because the class-wide type is not retrievable by - -- visbility. + if No (Actual) then + + -- If formal has a class-wide type rewrite as the corresponding + -- attribute, because the class-wide type is not retrievable by + -- visbility. + + if Is_Class_Wide_Type (Etype (F)) then + Parm_Type := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Class, + Prefix => + Make_Identifier (Loc, Chars (Etype (Etype (F))))); + + else + Parm_Type := + Make_Identifier (Loc, Chars (Etype (Etype (F)))); + end if; + + -- If actual is present, use the type of its own formal - if Is_Class_Wide_Type (Etype (F)) then - Parm_Type := - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Class, - Prefix => - Make_Identifier (Loc, Chars (Etype (Etype (F))))); else Parm_Type := New_Occurrence_Of (Etype (F), Loc); end if; @@ -1766,8 +1781,7 @@ package body Sem_Ch12 is else if GNATprove_Mode - and then - Present + and then Present (Containing_Package_With_Ext_Axioms (Defining_Entity (Analyzed_Formal))) and then Ekind (Defining_Entity (Analyzed_Formal)) = diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a5c77fc..1eac0b2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -371,8 +371,7 @@ package body Sem_Util is raise Program_Error; end if; - -- Contract items related to subprogram bodies. The applicable pragmas - -- are: + -- Contract items related to subprogram bodies. Applicable pragmas are: -- Refined_Depends -- Refined_Global -- Refined_Post @@ -392,7 +391,7 @@ package body Sem_Util is raise Program_Error; end if; - -- Contract items related to variables. The applicable pragmas are: + -- Contract items related to variables. Applicable pragmas are: -- Async_Readers -- Async_Writers -- Effective_Reads @@ -801,9 +800,7 @@ package body Sem_Util is return; end if; - if Is_Generic_Formal (Typ) - and then Is_Discrete_Type (Typ) - then + if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then Set_No_Predicate_On_Actual (Typ); end if; @@ -1442,8 +1439,7 @@ package body Sem_Util is pragma Assert (Has_Default_Init_Cond (Typ)); pragma Assert (Present (Prag)); - -- Nothing to do if the default initial condition procedure was already - -- built. + -- Nothing to do if default initial condition procedure already built if Present (Default_Init_Cond_Procedure (Typ)) then return; @@ -1909,7 +1905,7 @@ package body Sem_Util is return False; else return - Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) + Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) and then Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; @@ -1938,7 +1934,7 @@ package body Sem_Util is return False; else return - Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) + Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) and then Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; @@ -1992,6 +1988,7 @@ package body Sem_Util is and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type then -- The non-limited view is fully declared + null; else @@ -2429,7 +2426,7 @@ package body Sem_Util is elsif Nkind_In (Choice, N_Range, N_Subtype_Indication) or else (Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice))) + and then Is_Type (Entity (Choice))) then declare L, H : Node_Id; @@ -3049,7 +3046,8 @@ package body Sem_Util is Comes_From_Source (N) and then Is_Entity_Name (N) and then (Entity (N) = Standard_True - or else Entity (N) = Standard_False); + or else + Entity (N) = Standard_False); end Is_Trivial_Boolean; ------------------------- @@ -4747,7 +4745,8 @@ package body Sem_Util is -- attempt to detect partial overlap of slices. return Denotes_Same_Object (Lo1, Lo2) - and then Denotes_Same_Object (Hi1, Hi2); + and then + Denotes_Same_Object (Hi1, Hi2); end; -- In the recursion, literals appear as indexes @@ -4788,7 +4787,7 @@ package body Sem_Util is Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) then declare - Root1, Root2 : Node_Id; + Root1, Root2 : Node_Id; Depth1, Depth2 : Int := 0; begin @@ -4807,8 +4806,8 @@ package body Sem_Util is Root2 := Prefix (A2); while not Is_Entity_Name (Root2) loop - if not Nkind_In - (Root2, N_Selected_Component, N_Indexed_Component) + if not Nkind_In (Root2, N_Selected_Component, + N_Indexed_Component) then return False; else @@ -4826,7 +4825,7 @@ package body Sem_Util is elsif Depth1 > Depth2 then Root1 := Prefix (A1); - for I in 1 .. Depth1 - Depth2 - 1 loop + for J in 1 .. Depth1 - Depth2 - 1 loop Root1 := Prefix (Root1); end loop; @@ -4834,7 +4833,7 @@ package body Sem_Util is else Root2 := Prefix (A2); - for I in 1 .. Depth2 - Depth1 - 1 loop + for J in 1 .. Depth2 - Depth1 - 1 loop Root2 := Prefix (Root2); end loop; @@ -4897,7 +4896,6 @@ package body Sem_Util is begin if Nkind (N) = N_Defining_Program_Unit_Name then return Name (N); - else return Prefix (N); end if; @@ -4911,7 +4909,6 @@ package body Sem_Util is begin if Nkind (N) = N_Defining_Program_Unit_Name then return Defining_Identifier (N); - else return Selector_Name (N); end if; @@ -6552,9 +6549,8 @@ package body Sem_Util is if In_Spec_Expression then return Typ; - elsif Is_Private_Type (Typ) - and then not Has_Discriminants (Typ) - then + elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then + -- If the type has no discriminants, there is no subtype to -- build, even if the underlying type is discriminated. @@ -6793,7 +6789,6 @@ package body Sem_Util is -- For all other cases, we have a complete table of literals, and -- we simply iterate through the chain of literal until the one -- with the desired position value is found. - -- else if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then @@ -7579,7 +7574,7 @@ package body Sem_Util is elsif Default /= Unknown and then (Has_Size_Clause (Etype (Expr)) - or else + or else Has_Alignment_Clause (Etype (Expr))) then Set_Result (Unknown); @@ -7881,13 +7876,13 @@ package body Sem_Util is -- property is enabled when the flag evaluates to True or the flag is -- missing altogether. - elsif Property = Name_Async_Readers and then Is_Enabled (AR) then + elsif Property = Name_Async_Readers and then Is_Enabled (AR) then return True; - elsif Property = Name_Async_Writers and then Is_Enabled (AW) then + elsif Property = Name_Async_Writers and then Is_Enabled (AW) then return True; - elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then + elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then return True; elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then @@ -8027,7 +8022,7 @@ package body Sem_Util is elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then return Has_No_Obvious_Side_Effects (Left_Opnd (N)) - and then + and then Has_No_Obvious_Side_Effects (Right_Opnd (N)); elsif Nkind (N) = N_Expression_With_Actions @@ -8247,10 +8242,8 @@ package body Sem_Util is elsif Is_Entity_Name (N) and then (Ekind (Entity (N)) = E_Discriminant - or else - ((Ekind (Entity (N)) = E_Constant - or else Ekind (Entity (N)) = E_In_Parameter) - and then Present (Discriminal_Link (Entity (N))))) + or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) + and then Present (Discriminal_Link (Entity (N))))) then return True; @@ -8260,9 +8253,7 @@ package body Sem_Util is -- For aggregates we have to check that each of the associations -- is preelaborable. - elsif Nkind (N) = N_Aggregate - or else Nkind (N) = N_Extension_Aggregate - then + elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then Is_Array_Aggr := Is_Array_Type (Etype (N)); if Is_Array_Aggr then @@ -8564,7 +8555,8 @@ package body Sem_Util is if No (UT) then if No (Full_View (Btype)) then return not Is_Generic_Type (Btype) - and then not Is_Generic_Type (Root_Type (Btype)); + and then + not Is_Generic_Type (Root_Type (Btype)); else return not Is_Generic_Type (Root_Type (Full_View (Btype))); end if; @@ -8749,9 +8741,7 @@ package body Sem_Util is Comp : Entity_Id; begin - if Is_Private_Type (Typ) - and then Present (Underlying_Type (Typ)) - then + if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then return Has_Tagged_Component (Underlying_Type (Typ)); elsif Is_Array_Type (Typ) then @@ -8926,9 +8916,7 @@ package body Sem_Util is begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop - if (Ekind (S) = E_Function - or else Ekind (S) = E_Package - or else Ekind (S) = E_Procedure) + if Ekind_In (S, E_Function, E_Package, E_Procedure) and then Is_Generic_Instance (S) then -- A child instance is always compiled in the context of a parent @@ -9479,8 +9467,8 @@ package body Sem_Util is and then Is_Aliased_View (Renamed_Object (E))))) or else ((Is_Formal (E) - or else Ekind (E) = E_Generic_In_Out_Parameter - or else Ekind (E) = E_Generic_In_Parameter) + or else Ekind_In (E, E_Generic_In_Out_Parameter, + E_Generic_In_Parameter)) and then Is_Tagged_Type (Etype (E))) or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) @@ -9842,9 +9830,9 @@ package body Sem_Util is begin return Is_Interface (T) and then - (Is_Protected_Interface (T) - or else Is_Synchronized_Interface (T) - or else Is_Task_Interface (T)); + (Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T) + or else Is_Task_Interface (T)); end Is_Concurrent_Interface; --------------------------- @@ -10282,9 +10270,9 @@ package body Sem_Util is if not Is_Constrained (Prefix_Type) and then (not Is_Indefinite_Subtype (Prefix_Type) or else - (Is_Generic_Type (Prefix_Type) - and then Ekind (Current_Scope) = E_Generic_Package - and then In_Package_Body (Current_Scope))) + (Is_Generic_Type (Prefix_Type) + and then Ekind (Current_Scope) = E_Generic_Package + and then In_Package_Body (Current_Scope))) and then (Is_Declared_Within_Variant (Comp) or else Has_Discriminant_Dependent_Constraint (Comp)) @@ -10518,11 +10506,17 @@ package body Sem_Util is function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is begin - -- In Ada2012, a scalar type with an aspect Default_Value - -- is fully initialized. + -- Scalar types if Is_Scalar_Type (Typ) then - return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ); + + -- A scalar type with an aspect Default_Value is fully initialized + + -- Note: Iniitalize/Normalize_Scalars also ensure full initialization + -- of a scalar type, but we don't take that into account here, since + -- we don't want these to affect warnings. + + return Has_Default_Aspect (Typ); elsif Is_Access_Type (Typ) then return True; @@ -11786,7 +11780,10 @@ package body Sem_Util is Comp_Assn := First (Component_Associations (Orig_N)); while Present (Comp_Assn) loop Expr := Expression (Comp_Assn); - if Present (Expr) -- needed for box association + + -- Note: test for Present here needed for box assocation + + if Present (Expr) and then not Is_SPARK_05_Initialization_Expr (Expr) then Is_Ok := False; @@ -11890,7 +11887,8 @@ package body Sem_Util is return (Is_Tagged_Type (E) and then (Kind = E_Task_Type - or else Kind = E_Protected_Type)) + or else + Kind = E_Protected_Type)) or else (Is_Interface (E) and then Is_Synchronized_Interface (E)) @@ -12215,13 +12213,13 @@ package body Sem_Util is K : constant Entity_Kind := Ekind (E); begin - return (K = E_Variable - and then Nkind (Parent (E)) /= N_Exception_Handler) - or else (K = E_Component - and then not In_Protected_Function (E)) - or else K = E_Out_Parameter - or else K = E_In_Out_Parameter - or else K = E_Generic_In_Out_Parameter + return (K = E_Variable + and then Nkind (Parent (E)) /= N_Exception_Handler) + or else (K = E_Component + and then not In_Protected_Function (E)) + or else K = E_Out_Parameter + or else K = E_In_Out_Parameter + or else K = E_Generic_In_Out_Parameter -- Current instance of type. If this is a protected type, check -- we are not within the body of one of its protected functions. @@ -12270,10 +12268,10 @@ package body Sem_Util is return Is_Variable (Expression (Orig_Node)) and then (not Comes_From_Source (Orig_Node) - or else - (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) - and then - Is_Tagged_Type (Etype (Expression (Orig_Node))))); + or else + (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) + and then + Is_Tagged_Type (Etype (Expression (Orig_Node))))); -- GNAT allows an unchecked type conversion as a variable. This -- only affects the generation of internal expanded code, since @@ -13103,9 +13101,9 @@ package body Sem_Util is end if; end New_Copy_List_Tree; - ------------------- - -- New_Copy_Tree -- - ------------------- + -------------------------------------------------- + -- New_Copy_Tree Auxiliary Data and Subprograms -- + -------------------------------------------------- use Atree.Unchecked_Access; use Atree_Private_Part; @@ -13168,7 +13166,9 @@ package body Sem_Util is Hash => New_Copy_Hash, Equal => Types."="); - -- Start of processing for New_Copy_Tree function + ------------------- + -- New_Copy_Tree -- + ------------------- function New_Copy_Tree (Source : Node_Id; @@ -14321,9 +14321,9 @@ package body Sem_Util is then if No (Actuals) and then - Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Function_Call, - N_Parameter_Association) + Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Function_Call, + N_Parameter_Association) and then Ekind (S) /= E_Function then Set_Etype (N, Etype (S)); @@ -14332,8 +14332,8 @@ package body Sem_Util is Error_Msg_Name_1 := Chars (S); Error_Msg_Sloc := Sloc (S); Error_Msg_NE - ("missing argument for parameter & " & - "in call to % declared #", N, Formal); + ("missing argument for parameter & " + & "in call to % declared #", N, Formal); end if; elsif Is_Overloadable (S) then @@ -14345,8 +14345,8 @@ package body Sem_Util is Error_Msg_Sloc := Sloc (Parent (S)); Error_Msg_NE - ("missing argument for parameter & " & - "in call to % (inherited) #", N, Formal); + ("missing argument for parameter & " + & "in call to % (inherited) #", N, Formal); else Error_Msg_NE @@ -14504,8 +14504,7 @@ package body Sem_Util is -- sure this is a modification. if Has_Pragma_Unmodified (Ent) and then Sure then - Error_Msg_NE - ("??pragma Unmodified given for &!", N, Ent); + Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent); end if; Set_Never_Set_In_Source (Ent, False); @@ -15049,7 +15048,7 @@ package body Sem_Util is -- would cause infinite recursion. elsif Ekind (Subp) = E_Function - and then (Is_Predicate_Function (Subp) + and then (Is_Predicate_Function (Subp) or else Is_Predicate_Function_M (Subp)) then @@ -15780,11 +15779,7 @@ package body Sem_Util is if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) or else - Ekind (Ent) = E_Constant - or else - Ekind (Ent) = E_Out_Parameter - or else - Ekind (Ent) = E_In_Out_Parameter + Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter) then null; @@ -17789,6 +17784,7 @@ package body Sem_Util is Op : constant Node_Id := Right_Opnd (Parent (Expr)); L : constant Node_Id := Left_Opnd (Op); R : constant Node_Id := Right_Opnd (Op); + begin -- The case for the message is when the left operand of the -- comparison is the same modular type, or when it is an diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 4eaf51f..bfa33e0 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4246,6 +4246,11 @@ package Sinfo is -- point operands if the Treat_Fixed_As_Integer flag is set and will -- thus treat these nodes in identical manner, ignoring small values. + -- Note on equality/inequality tests for records. In the expanded tree, + -- record comparisons are always expanded to be a series of component + -- comparisons, so the back end will never see an equality or inequality + -- operation with operands of a record type. + -- Note on overflow handling: When the overflow checking mode is set to -- MINIMIZED or ELIMINATED, nodes for signed arithmetic operations may -- be modified to use a larger type for the operands and result. In |