From: Ed Schonberg Date: Mon, 1 Oct 2012 08:39:43 +0000 (+0000) Subject: aspects.ads: Type_Invariant'class is a valid aspect. X-Git-Tag: misc/gccgo-go1_1_2~533 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=9e1902a9e7e3cb06d33ad2c1e1e002d2ba0973ec;p=thirdparty%2Fgcc.git aspects.ads: Type_Invariant'class is a valid aspect. 2012-10-01 Ed Schonberg * aspects.ads: Type_Invariant'class is a valid aspect. * sem_ch6.adb (Is_Public_Subprogram_For): with the exception of initialization procedures, subprograms that do not come from source are not public for the purpose of invariant checking. * sem_ch13.adb (Build_Invariant_Procedure): Handle properly the case of a non-private type in a package without a private part, when the type inherits invariants from its ancestor. 2012-10-01 Ed Schonberg * exp_ch3.adb (Build_Record_Invariant_Proc): new procedure to generate a checking procedure for record types that may have components whose types have type invariants declared. From-SVN: r191901 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 06be8c91b191..d0f86178e572 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2012-10-01 Ed Schonberg + + * aspects.ads: Type_Invariant'class is a valid aspect. + * sem_ch6.adb (Is_Public_Subprogram_For): with the exception of + initialization procedures, subprograms that do not come from + source are not public for the purpose of invariant checking. + * sem_ch13.adb (Build_Invariant_Procedure): Handle properly the + case of a non-private type in a package without a private part, + when the type inherits invariants from its ancestor. + +2012-10-01 Ed Schonberg + + * exp_ch3.adb (Build_Record_Invariant_Proc): new procedure to + generate a checking procedure for record types that may have + components whose types have type invariants declared. + 2012-10-01 Vincent Pucci * system-solaris-sparcv9.ads, system-mingw.ads, system-vms_64.ads: Flag diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index ebe71aec0c35..12e5e6b52c94 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -191,11 +191,12 @@ package Aspects is -- The following array indicates aspects that accept 'Class Class_Aspect_OK : constant array (Aspect_Id) of Boolean := - (Aspect_Invariant => True, - Aspect_Pre => True, - Aspect_Predicate => True, - Aspect_Post => True, - others => False); + (Aspect_Invariant => True, + Aspect_Pre => True, + Aspect_Predicate => True, + Aspect_Post => True, + Aspect_Type_Invariant => True, + others => False); -- The following array indicates aspects that a subtype inherits from -- its base type. True means that the subtype inherits the aspect from diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1059da6955b2..293c902389da 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -118,6 +118,10 @@ package body Exp_Ch3 is -- Build record initialization procedure. N is the type declaration -- node, and Rec_Ent is the corresponding entity for the record type. + procedure Build_Record_Invariant_Proc (R_Type : Entity_Id; Nod : Node_Id); + -- If the record type has components whose types have invariant, build + -- an invariant procedure for the record type itself. + procedure Build_Slice_Assignment (Typ : Entity_Id); -- Build assignment procedure for one-dimensional arrays of controlled -- types. Other array and slice assignments are expanded in-line, but @@ -3611,6 +3615,174 @@ package body Exp_Ch3 is end if; end Build_Record_Init_Proc; + -------------------------------- + -- Build_Record_Invariant_Proc -- + -------------------------------- + + procedure Build_Record_Invariant_Proc (R_Type : Entity_Id; Nod : Node_Id) is + Loc : constant Source_Ptr := Sloc (Nod); + + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of invariant procedure + + Object_Entity : constant Node_Id := + Make_Defining_Identifier (Loc, Object_Name); + -- The procedure declaration entity for the argument + + Invariant_Found : Boolean; + -- Set if any component needs an invariant check. + + Proc_Id : Entity_Id; + Proc_Body : Node_Id; + Stmts : List_Id; + Type_Def : Node_Id; + + function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id; + -- Recursive procedure that generates a list of checks for components + -- that need it, and recurses through variant parts when present. + + function Build_Component_Invariant_Call (Comp : Entity_Id) + return Node_Id; + -- Build call to invariant procedure for a record component. + + ------------------------------------ + -- Build_Component_Invariant_Call -- + ------------------------------------ + + function Build_Component_Invariant_Call (Comp : Entity_Id) + return Node_Id + is + Sel_Comp : Node_Id; + + begin + Invariant_Found := True; + Sel_Comp := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Object_Entity, Loc), + Selector_Name => New_Occurrence_Of (Comp, Loc)); + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (Invariant_Procedure (Etype (Comp)), Loc), + Parameter_Associations => New_List (Sel_Comp)); + end Build_Component_Invariant_Call; + + ---------------------------- + -- Build_Invariant_Checks -- + ---------------------------- + + function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id is + Decl : Node_Id; + Id : Entity_Id; + Stmts : List_Id; + + begin + Stmts := New_List; + Decl := First_Non_Pragma (Component_Items (Comp_List)); + + while Present (Decl) loop + if Nkind (Decl) = N_Component_Declaration then + Id := Defining_Identifier (Decl); + if Has_Invariants (Etype (Id)) then + Append_To (Stmts, Build_Component_Invariant_Call (Id)); + end if; + end if; + + Next (Decl); + end loop; + + if Present (Variant_Part (Comp_List)) then + declare + Variant_Alts : constant List_Id := New_List; + Var_Loc : Source_Ptr; + Variant : Node_Id; + Variant_Stmts : List_Id; + + begin + Variant := + First_Non_Pragma (Variants (Variant_Part (Comp_List))); + while Present (Variant) loop + Variant_Stmts := + Build_Invariant_Checks (Component_List (Variant)); + Var_Loc := Sloc (Variant); + Append_To (Variant_Alts, + Make_Case_Statement_Alternative (Var_Loc, + Discrete_Choices => + New_Copy_List (Discrete_Choices (Variant)), + Statements => Variant_Stmts)); + + Next_Non_Pragma (Variant); + end loop; + + -- The expression in the case statement is the reference to + -- the discriminant of the target object. + + Append_To (Stmts, + Make_Case_Statement (Var_Loc, + Expression => + Make_Selected_Component (Var_Loc, + Prefix => New_Occurrence_Of (Object_Entity, Var_Loc), + Selector_Name => New_Occurrence_Of + (Entity + (Name (Variant_Part (Comp_List))), Var_Loc)), + Alternatives => Variant_Alts)); + end; + end if; + + return Stmts; + end Build_Invariant_Checks; + + begin + Invariant_Found := False; + Type_Def := Type_Definition (Parent (R_Type)); + if Nkind (Type_Def) = N_Record_Definition + and then not Null_Present (Type_Def) + then + Stmts := + Build_Invariant_Checks (Component_List (Type_Def)); + else + return; + end if; + + if not Invariant_Found then + return; + end if; + + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (R_Type), "Invariant")); + Set_Has_Invariants (Proc_Id); + Set_Has_Invariants (R_Type); + Set_Invariant_Procedure (R_Type, Proc_Id); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (R_Type, Loc)))), + + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + Set_Ekind (Proc_Id, E_Procedure); + Set_Is_Public (Proc_Id, Is_Public (R_Type)); + Set_Is_Internal (Proc_Id); + Set_Has_Completion (Proc_Id); + + -- The procedure body is placed after the freeze node for the type. + + Insert_After (Nod, Proc_Body); + Analyze (Proc_Body); + end Build_Record_Invariant_Proc; + ---------------------------- -- Build_Slice_Assignment -- ---------------------------- @@ -6637,6 +6809,10 @@ package body Exp_Ch3 is end loop; end; end if; + + if not Has_Invariants (Def_Id) then + Build_Record_Invariant_Proc (Def_Id, N); + end if; end Expand_Freeze_Record_Type; ------------------------------ diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index caa674105933..c93fd7e37f14 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -5188,9 +5188,6 @@ package body Sem_Ch13 is Statements => Stmts)); -- Insert procedure declaration and spec at the appropriate points. - -- Skip this if there are no private declarations (that's an error - -- that will be diagnosed elsewhere, and there is no point in having - -- an invariant procedure set if the full declaration is missing). if Present (Private_Decls) then @@ -5214,6 +5211,19 @@ package body Sem_Ch13 is if In_Private_Part (Current_Scope) then Analyze (PBody); end if; + + -- If there are no private declarations this may be an error that + -- will be diagnosed elsewhere. However, if this is a non-private + -- type that inherits invariants, it needs no completion and there + -- may be no private part. In this case insert invariant procedure + -- at end of current declarative list, and analyze at once, given + -- that the type is about to be frozen. + + elsif not Is_Private_Type (Typ) then + Append_To (Visible_Decls, PDecl); + Append_To (Visible_Decls, PBody); + Analyze (PDecl); + Analyze (PBody); end if; end if; end Build_Invariant_Procedure; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d48dd10e524d..c71c2db3eaa8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -11342,10 +11342,16 @@ package body Sem_Ch6 is -- If the subprogram declaration is not a list member, it must be -- an Init_Proc, in which case we want to consider it to be a -- public subprogram, since we do get initializations to deal with. + -- Other internally generated subprograms are not public. - if not Is_List_Member (DD) then + if not Is_List_Member (DD) + and then Is_Init_Proc (DD) + then return True; + elsif not Comes_From_Source (DD) then + return False; + -- Otherwise we test whether the subprogram is declared in the -- visible declarations of the package containing the type.