diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f93439edff3..c4097993ea5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2015-10-26 Bob Duff + + * snames.ads-tmpl, aspects.adb, aspects.ads: Add the aspect and + pragma names and enter into relevant tables. + * sem_ch13.adb (Analyze_Aspect_Specifications): Analyze aspect + Predicate_Failure. + * sem_prag.adb (Predicate_Failure): Analyze pragma Predicate_Failure. + * exp_util.adb (Make_Predicate_Check): When building the Check + pragma, if Predicate_Failure has been specified, add the relevant + String argument to the pragma. + * par-prag.adb (Prag): Add Predicate_Failure to list of pragmas + handled during semantic analysis. + +2015-10-26 Ed Schonberg + + * sem_ch5.adb (Analyze_Assignment): If the left-hand side + is an indexed component with generalized indexing, discard + interpretation that yields a reference type, which is not + assignable. This prevent spurious ambiguities when the right-hand + side is an aggregate which does not provide a target type. + 2015-10-26 Bob Duff * exp_ch7.adb, exp_ch6.adb: Minor comment fix. diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index e2bf1ead8f7..4398f922805 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -582,6 +582,7 @@ package body Aspects is Aspect_Pre => Aspect_Pre, Aspect_Precondition => Aspect_Pre, Aspect_Predicate => Aspect_Predicate, + Aspect_Predicate_Failure => Aspect_Predicate_Failure, Aspect_Preelaborate => Aspect_Preelaborate, Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization, Aspect_Priority => Aspect_Priority, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 55c51a14a6b..5e042ada03e 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -125,6 +125,7 @@ package Aspects is Aspect_Pre, Aspect_Precondition, Aspect_Predicate, -- GNAT + Aspect_Predicate_Failure, Aspect_Priority, Aspect_Read, Aspect_Refined_Depends, -- GNAT @@ -361,6 +362,7 @@ package Aspects is Aspect_Pre => Expression, Aspect_Precondition => Expression, Aspect_Predicate => Expression, + Aspect_Predicate_Failure => Expression, Aspect_Priority => Expression, Aspect_Read => Name, Aspect_Refined_Depends => Expression, @@ -472,6 +474,7 @@ package Aspects is Aspect_Pre => Name_Pre, Aspect_Precondition => Name_Precondition, Aspect_Predicate => Name_Predicate, + Aspect_Predicate_Failure => Name_Predicate_Failure, Aspect_Preelaborable_Initialization => Name_Preelaborable_Initialization, Aspect_Preelaborate => Name_Preelaborate, Aspect_Priority => Name_Priority, @@ -587,7 +590,7 @@ package Aspects is -- constructs. To handle forward references in such aspects, the compiler -- delays the analysis of their respective pragmas by collecting them in -- N_Contract nodes. The pragmas are then analyzed at the end of the - -- declarative region which contains the related construct. For details, + -- declarative region containing the related construct. For details, -- see routines Analyze_xxx_In_Decl_Part. -- The following shows which aspects are delayed. There are three cases: @@ -676,6 +679,7 @@ package Aspects is Aspect_Pre => Always_Delay, Aspect_Precondition => Always_Delay, Aspect_Predicate => Always_Delay, + Aspect_Predicate_Failure => Always_Delay, Aspect_Preelaborable_Initialization => Always_Delay, Aspect_Preelaborate => Always_Delay, Aspect_Priority => Always_Delay, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index aec73203696..d546fa8d773 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6507,8 +6507,9 @@ package body Exp_Util is (Typ : Entity_Id; Expr : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Expr); - Nam : Name_Id; + Loc : constant Source_Ptr := Sloc (Expr); + Nam : Name_Id; + Arg_List : List_Id; begin -- If predicate checks are suppressed, then return a null statement. @@ -6537,14 +6538,24 @@ package body Exp_Util is Nam := Name_Predicate; end if; + Arg_List := New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Nam)), + Make_Pragma_Argument_Association (Loc, + Expression => Make_Predicate_Call (Typ, Expr))); + + if Has_Aspect (Typ, Aspect_Predicate_Failure) then + Append_To (Arg_List, + Make_Pragma_Argument_Association (Loc, + Expression => + New_Copy_Tree (Expression + (Find_Aspect (Typ, Aspect_Predicate_Failure))))); + end if; + return Make_Pragma (Loc, Pragma_Identifier => Make_Identifier (Loc, Name_Check), - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Nam)), - Make_Pragma_Argument_Association (Loc, - Expression => Make_Predicate_Call (Typ, Expr)))); + Pragma_Argument_Associations => Arg_List); end Make_Predicate_Check; ---------------------------- @@ -9427,7 +9438,8 @@ package body Exp_Util is return Present (S) and then Get_TSS_Name (S) /= TSS_Null - and then not Is_Predicate_Function (S); + and then not Is_Predicate_Function (S) + and then not Is_Predicate_Function_M (S); end Within_Internal_Subprogram; ---------------------------- diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index a3ed732995b..c317949d7c2 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1421,6 +1421,7 @@ begin Pragma_Pre | Pragma_Precondition | Pragma_Predicate | + Pragma_Predicate_Failure | Pragma_Preelaborate | Pragma_Pre_Class | Pragma_Priority | diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d02d8e5bbfb..36eb7ad5490 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1642,7 +1642,7 @@ package body Sem_Ch13 is end if; Set_Corresponding_Aspect (Aitem, Aspect); - Set_From_Aspect_Specification (Aitem, True); + Set_From_Aspect_Specification (Aitem); end Make_Aitem_Pragma; -- Start of processing for Analyze_One_Aspect @@ -1979,7 +1979,7 @@ package body Sem_Ch13 is Expression => Ent), Make_Pragma_Argument_Association (Sloc (Expr), Expression => Relocate_Node (Expr))), - Pragma_Name => Name_Predicate); + Pragma_Name => Name_Predicate); -- Mark type has predicates, and remember what kind of -- aspect lead to this predicate (we need this to access @@ -2010,6 +2010,46 @@ package body Sem_Ch13 is Ensure_Freeze_Node (Full_View (E)); end if; + -- Predicate_Failure + + when Aspect_Predicate_Failure => + + -- This aspect applies only to subtypes + + if not Is_Type (E) then + Error_Msg_N + ("predicate can only be specified for a subtype", + Aspect); + goto Continue; + + elsif Is_Incomplete_Type (E) then + Error_Msg_N + ("predicate cannot apply to incomplete view", Aspect); + goto Continue; + end if; + + -- Construct the pragma + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Predicate_Failure); + + Set_Has_Predicates (E); + + -- If the type is private, indicate that its completion + -- has a freeze node, because that is the one that will + -- be visible at freeze time. + + if Is_Private_Type (E) and then Present (Full_View (E)) then + Set_Has_Predicates (Full_View (E)); + Set_Has_Delayed_Aspects (Full_View (E)); + Ensure_Freeze_Node (Full_View (E)); + end if; + -- Case 2b: Aspects corresponding to pragmas with two -- arguments, where the second argument is a local name -- referring to the entity, and the first argument is the @@ -7670,7 +7710,7 @@ package body Sem_Ch13 is -- Start of processing for Build_Discrete_Static_Predicate begin - -- Establish bounds for the predicate + -- Establish bounds for the predicate if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then TLo := Expr_Value (Type_Low_Bound (Typ)); @@ -9373,6 +9413,9 @@ package body Sem_Ch13 is Aspect_Type_Invariant => T := Standard_Boolean; + when Aspect_Predicate_Failure => + T := Standard_String; + -- Here is the list of aspects that don't require delay analysis when Aspect_Abstract_State | @@ -12509,9 +12552,10 @@ package body Sem_Ch13 is case A_Id is -- For now we only deal with aspects that do not generate -- subprograms, or that may mention current instances of - -- types. These will require special handling (TBD). + -- types. These will require special handling (???TBD). when Aspect_Predicate | + Aspect_Predicate_Failure | Aspect_Invariant | Aspect_Static_Predicate | Aspect_Dynamic_Predicate => diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 3e791799c2a..0c9c56e2e2e 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -316,7 +316,18 @@ package body Sem_Ch5 is Get_First_Interp (Lhs, I, It); while Present (It.Typ) loop - if Has_Compatible_Type (Rhs, It.Typ) then + -- An indexed component with generalized indexing is always + -- overloaded with the corresponding dereference. Discard + -- the interpretation that yields a reference type, which + -- is not assignable. + + if Nkind (Lhs) = N_Indexed_Component + and then Present (Generalized_Indexing (Lhs)) + and then Has_Implicit_Dereference (It.Typ) + then + null; + + elsif Has_Compatible_Type (Rhs, It.Typ) then if T1 /= Any_Type then -- An explicit dereference is overloaded if the prefix diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0b6e64d66a8..cd5f9d03bdd 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -18243,6 +18243,47 @@ package body Sem_Prag is Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); end Predicate; + ----------------------- + -- Predicate_Failure -- + ----------------------- + + -- pragma Predicate_Failure + -- ([Entity =>] type_LOCAL_NAME, + -- [Message =>] string_EXPRESSION); + + when Pragma_Predicate_Failure => Predicate_Failure : declare + Discard : Boolean; + Typ : Entity_Id; + Type_Id : Node_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Optional_Identifier (Arg2, Name_Message); + + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Get_Pragma_Arg (Arg1); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type then + return; + end if; + + -- A pragma that applies to a Ghost entity becomes Ghost for the + -- purposes of legality checks and removal of ignored Ghost code. + + Mark_Pragma_As_Ghost (N, Typ); + + -- The remaining processing is simply to link the pragma on to + -- the rep item chain, for processing when the type is frozen. + -- This is accomplished by a call to Rep_Item_Too_Late. + + Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); + end Predicate_Failure; + ------------------ -- Preelaborate -- ------------------ @@ -27291,7 +27332,7 @@ package body Sem_Prag is -- 0 indicates that appearance in any argument is not significant -- +n indicates that appearance as argument n is significant, but all -- other arguments are not significant - -- 9n arguments from n on are significant, before n inisignificant + -- 9n arguments from n on are significant, before n insignificant Sig_Flags : constant array (Pragma_Id) of Int := (Pragma_Abort_Defer => -1, @@ -27446,6 +27487,7 @@ package body Sem_Prag is Pragma_Pre => -1, Pragma_Precondition => -1, Pragma_Predicate => -1, + Pragma_Predicate_Failure => -1, Pragma_Preelaborable_Initialization => -1, Pragma_Preelaborate => 0, Pragma_Pre_Class => -1, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 6d9ca7df3ca..76d8028252c 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -570,6 +570,7 @@ package Snames is Name_Pre : constant Name_Id := N + $; -- GNAT Name_Precondition : constant Name_Id := N + $; -- GNAT Name_Predicate : constant Name_Id := N + $; -- GNAT + Name_Predicate_Failure : constant Name_Id := N + $; -- Ada 12 Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 05 Name_Preelaborate : constant Name_Id := N + $; Name_Pre_Class : constant Name_Id := N + $; -- GNAT @@ -1895,6 +1896,7 @@ package Snames is Pragma_Pre, Pragma_Precondition, Pragma_Predicate, + Pragma_Predicate_Failure, Pragma_Preelaborable_Initialization, Pragma_Preelaborate, Pragma_Pre_Class,