diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 07ac917b9f2..218c225cbcc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2014-07-29 Ed Schonberg + + * sem_ch4.adb (Complete_Object_Operation): If the type of the + candidate subprogram is a limited view, use non-limited view + when available. + +2014-07-29 Robert Dewar + + * sem_ch13.adb: Minor change in RM reference. + * sem_mech.ads: Minor reformatting. + * einfo.ads: Minor comment fix. + * types.ads: Minor correction to range given for Mechanism_Type. + * exp_ch6.adb (Add_Invariant_And_Predicate_Checks): Do not + check predicate on way out for OUT or IN OUT parameters. + * par-ch3.adb (P_Constraint_Opt): Handle missing RANGE keyword + better (P_Range_Constraint): Corresponding fix. + * checks.ads: Minor comment clarification. + +2014-07-29 Gary Dismukes + + * sem_ch8.adb (Analyze_Object_Renaming): Set the Is_Volatile + and Treat_As_Volatile flags based on whether the renamed object + is a volatile object. + 2014-07-29 Olivier Hainque * g-debpoo.adb diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 7244e3c6a66..07fdc5dc3c8 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -245,8 +245,7 @@ package Checks is procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id); -- N is an expression to which a predicate check may need to be applied - -- for Typ, if Typ has a predicate function. The check is applied only - -- if the type of N does not match Typ. + -- for Typ, if Typ has a predicate function. procedure Apply_Type_Conversion_Checks (N : Node_Id); -- N is an N_Type_Conversion node. A type conversion actually involves diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 4117252280d..6065d19ba94 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3172,9 +3172,9 @@ package Einfo is -- Mechanism (Uint8) (returned as Mechanism_Type) -- Defined in functions and non-generic formal parameters. Indicates -- the mechanism to be used for the function return or for the formal --- parameter. See separate section on passing mechanisms. This field --- is also set (to the default value of zero) in a subprogram body --- entity but not used in this context. +-- parameter. See full description in the spec of Sem_Mech. This field +-- is also set (to the default value of zero = Default_Mechanism) in a +-- subprogram body entity but not used in this context. -- Modulus (Uint17) [base type only] -- Defined in modular types. Contains the modulus. For the binary case, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index a1d080abe58..9344e40aad8 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -8248,10 +8248,6 @@ package body Exp_Ch6 is -- subprogram Subp_Id must appear visible from the point of view of -- the type. - function Predicate_Checks_OK (Typ : Entity_Id) return Boolean; - -- Determine whether type Typ can benefit from predicate checks. To - -- qualify, the type must have at least one checked predicate. - --------------------------------- -- Add_Invariant_Access_Checks -- --------------------------------- @@ -8414,57 +8410,6 @@ package body Exp_Ch6 is and then Has_Public_Visibility_Of_Subprogram; end Invariant_Checks_OK; - ------------------------- - -- Predicate_Checks_OK -- - ------------------------- - - function Predicate_Checks_OK (Typ : Entity_Id) return Boolean is - function Has_Checked_Predicate return Boolean; - -- Determine whether type Typ has or inherits at least one - -- predicate aspect or pragma, for which the applicable policy is - -- Checked. - - --------------------------- - -- Has_Checked_Predicate -- - --------------------------- - - function Has_Checked_Predicate return Boolean is - Anc : Entity_Id; - Pred : Node_Id; - - begin - -- Climb the ancestor type chain staring from the input. This - -- is done because the input type may lack aspect/pragma - -- predicate and simply inherit those from its ancestor. - - -- Note that predicate pragmas correspond to all three cases - -- of predicate aspects (Predicate, Dynamic_Predicate, and - -- Static_Predicate), so this routine checks for all three - -- cases. - - Anc := Typ; - while Present (Anc) loop - Pred := Get_Pragma (Anc, Pragma_Predicate); - - if Present (Pred) and then not Is_Ignored (Pred) then - return True; - end if; - - Anc := Nearest_Ancestor (Anc); - end loop; - - return False; - end Has_Checked_Predicate; - - -- Start of processing for Predicate_Checks_OK - - begin - return - Has_Predicates (Typ) - and then Present (Predicate_Function (Typ)) - and then Has_Checked_Predicate; - end Predicate_Checks_OK; - -- Local variables Loc : constant Source_Ptr := Sloc (N); @@ -8529,12 +8474,11 @@ package body Exp_Ch6 is Add_Invariant_Access_Checks (Formal); - if Predicate_Checks_OK (Typ) then - Append_Enabled_Item - (Item => Make_Predicate_Check - (Typ, New_Occurrence_Of (Formal, Loc)), - List => Stmts); - end if; + -- Note: we used to add predicate checks for OUT and IN OUT + -- formals here, but that was misguided, since such checks are + -- performed on the caller side, based on the predicate of the + -- actual, rather than the predicate of the formal. + end if; Next_Formal (Formal); diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index e9524fa4de7..3d6161b2165 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, 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- -- @@ -1217,19 +1217,13 @@ package body Ch3 is function P_Constraint_Opt return Node_Id is begin - if Token = Tok_Range - or else Bad_Spelling_Of (Tok_Range) - then + if Token = Tok_Range or else Bad_Spelling_Of (Tok_Range) then return P_Range_Constraint; - elsif Token = Tok_Digits - or else Bad_Spelling_Of (Tok_Digits) - then + elsif Token = Tok_Digits or else Bad_Spelling_Of (Tok_Digits) then return P_Digits_Constraint; - elsif Token = Tok_Delta - or else Bad_Spelling_Of (Tok_Delta) - then + elsif Token = Tok_Delta or else Bad_Spelling_Of (Tok_Delta) then return P_Delta_Constraint; elsif Token = Tok_Left_Paren then @@ -1239,6 +1233,31 @@ package body Ch3 is Ignore (Tok_In); return P_Constraint_Opt; + -- One more possibility is e.g. 1 .. 10 (i.e. missing RANGE keyword) + + elsif Token = Tok_Identifier or else + Token = Tok_Integer_Literal or else + Token = Tok_Real_Literal + then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); -- at identifier or literal + Scan; -- past identifier or literal + + if Token = Tok_Dot_Dot then + Restore_Scan_State (Scan_State); + Error_Msg_BC ("missing RANGE keyword"); + return P_Range_Constraint; + else + Restore_Scan_State (Scan_State); + return Empty; + end if; + end; + + -- Nothing worked, no constraint there + else return Empty; end if; @@ -2033,7 +2052,9 @@ package body Ch3 is -- RANGE_CONSTRAINT ::= range RANGE - -- The caller has checked that the initial token is RANGE + -- The caller has checked that the initial token is RANGE or some + -- misspelling of it, or it may be absent completely (and a message + -- has already been issued). -- Error recovery: cannot raise Error_Resync @@ -2042,7 +2063,13 @@ package body Ch3 is begin Range_Node := New_Node (N_Range_Constraint, Token_Ptr); - Scan; -- past RANGE + + -- Skip range keyword if present + + if Token = Tok_Range or else Bad_Spelling_Of (Tok_Range) then + Scan; -- past RANGE + end if; + Set_Range_Expression (Range_Node, P_Range); return Range_Node; end P_Range_Constraint; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f6a4be12f83..35f4f8a6fcb 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8097,7 +8097,7 @@ package body Sem_Ch13 is if Has_Static_Predicate_Aspect (Typ) then if Is_Scalar_Type (Typ) or else Is_String_Type (Typ) then Error_Msg_F - ("expression is not predicate-static (RM 4.3.2(16-22))", + ("expression is not predicate-static (RM 3.2.4(16-22))", EN); else Error_Msg_F diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 8ac94e92602..313f6f87d29 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7542,6 +7542,18 @@ package body Sem_Ch4 is Save_Interps (Subprog, Node_To_Replace); else + -- The type of the subprogram may be a limited view obtained + -- transitively from another unit. If full view is available, + -- use it to analyze call. + + declare + T : constant Entity_Id := Etype (Subprog); + begin + if From_Limited_With (T) then + Set_Etype (Entity (Subprog), Available_View (T)); + end if; + end; + Analyze (Node_To_Replace); -- If the operation has been rewritten into a call, which may get @@ -7587,7 +7599,7 @@ package body Sem_Ch4 is if Nkind (Parent (Op)) = N_Full_Type_Declaration then Error_Msg_N ("\possible interpretation " - & "( inherited, with implicit dereference) #", N); + & "(inherited, with implicit dereference) #", N); else Error_Msg_N ("\possible interpretation (with implicit dereference) #", N); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 8643caee853..ccfc2084bf4 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1245,17 +1245,17 @@ package body Sem_Ch8 is elsif Nkind (Original_Node (Nam)) = N_Function_Call - -- When expansion is disabled, attribute reference is not - -- rewritten as function call. Otherwise it may be rewritten - -- as a conversion, so check original node. + -- When expansion is disabled, attribute reference is not rewritten + -- as function call. Otherwise it may be rewritten as a conversion, + -- so check original node. or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference and then Is_Function_Attribute_Name (Attribute_Name (Original_Node (Nam)))) - -- Weird but legal, equivalent to renaming a function call. - -- Illegal if the literal is the result of constant-folding an - -- attribute reference that is not a function. + -- Weird but legal, equivalent to renaming a function call. Illegal + -- if the literal is the result of constant-folding an attribute + -- reference that is not a function. or else (Is_Entity_Name (Nam) and then Ekind (Entity (Nam)) = E_Enumeration_Literal @@ -1296,6 +1296,28 @@ package body Sem_Ch8 is Set_Is_True_Constant (Id, True); end if; + -- The entity of the renaming declaration needs to reflect whether the + -- renamed object is volatile. Is_Volatile is set if the renamed object + -- is volatile in the RM legality sense. + + Set_Is_Volatile (Id, Is_Volatile_Object (Nam)); + + -- Treat as volatile if we just set the Volatile flag + + if Is_Volatile (Id) + + -- Or if we are renaming an entity which was marked this way + + -- Are there more cases, e.g. X(J) where X is Treat_As_Volatile ??? + + or else (Is_Entity_Name (Nam) + and then Treat_As_Volatile (Entity (Nam))) + then + Set_Treat_As_Volatile (Id, True); + end if; + + -- Now make the link to the renamed object + Set_Renamed_Object (Id, Nam); -- Implementation-defined aspect specifications can appear in a renaming diff --git a/gcc/ada/sem_mech.ads b/gcc/ada/sem_mech.ads index 93f6080f1f4..3e74a2c2fa2 100644 --- a/gcc/ada/sem_mech.ads +++ b/gcc/ada/sem_mech.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-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- -- @@ -36,7 +36,7 @@ package Sem_Mech is ------------------------------------------------- -- For parameters passed to subprograms, and for function return values, - -- as passing mechanism is defined. The entity attribute Mechanism returns + -- a passing mechanism is defined. The entity attribute Mechanism returns -- an indication of the mechanism, and Set_Mechanism can be used to set -- the mechanism. At the program level, there are three ways to explicitly -- set the mechanism: @@ -87,14 +87,14 @@ package Sem_Mech is -- special information) is determined by the backend in accordance with -- requirements imposed by the ABI as interpreted for Ada. - By_Descriptor : constant Mechanism_Type := -3; - By_Descriptor_UBS : constant Mechanism_Type := -4; - By_Descriptor_UBSB : constant Mechanism_Type := -5; - By_Descriptor_UBA : constant Mechanism_Type := -6; - By_Descriptor_S : constant Mechanism_Type := -7; - By_Descriptor_SB : constant Mechanism_Type := -8; - By_Descriptor_A : constant Mechanism_Type := -9; - By_Descriptor_NCA : constant Mechanism_Type := -10; + By_Descriptor : constant Mechanism_Type := -3; + By_Descriptor_UBS : constant Mechanism_Type := -4; + By_Descriptor_UBSB : constant Mechanism_Type := -5; + By_Descriptor_UBA : constant Mechanism_Type := -6; + By_Descriptor_S : constant Mechanism_Type := -7; + By_Descriptor_SB : constant Mechanism_Type := -8; + By_Descriptor_A : constant Mechanism_Type := -9; + By_Descriptor_NCA : constant Mechanism_Type := -10; By_Short_Descriptor : constant Mechanism_Type := -11; By_Short_Descriptor_UBS : constant Mechanism_Type := -12; By_Short_Descriptor_UBSB : constant Mechanism_Type := -13; @@ -115,10 +115,13 @@ package Sem_Mech is -- A contiguous array -- NCA non-contiguous array -- - -- Note: the form with no suffix is used if the Import/Export pragma - -- uses the simple form of the mechanism name where no descriptor - -- type is supplied. In this case the back end assigns a descriptor - -- type based on the Ada type in accordance with the OpenVMS ABI. + -- Note: the form with no suffix is used if the Import/Export pragma uses + -- the simple form of the mechanism name (no descriptor type is supplied). + -- In this case the back end assigns a descriptor type based on the Ada + -- type in accordance with the OpenVMS ABI. + + pragma Assert (Mechanism_Type'First = -18); + -- Check definition in types is right! subtype Descriptor_Codes is Mechanism_Type range By_Short_Descriptor_NCA .. By_Descriptor; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index c54097b2c48..061dfc26c68 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -795,7 +795,7 @@ package Types is -- mechanism. See specification of Sem_Mech for full details. The following -- subtype is used to represent values of this type: - subtype Mechanism_Type is Int range -18 .. Int'Last; + subtype Mechanism_Type is Int range -18 .. 0; -- Type used to represent a mechanism value. This is a subtype rather than -- a type to avoid some annoying processing problems with certain routines -- in Einfo (processing them to create the corresponding C).