diff options
Diffstat (limited to 'gcc/ada/exp_ch13.adb')
-rw-r--r-- | gcc/ada/exp_ch13.adb | 325 |
1 files changed, 325 insertions, 0 deletions
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 9cdef48449e..bee33254b90 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -26,6 +26,7 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; +with Elists; use Elists; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Imgv; use Exp_Imgv; @@ -37,6 +38,8 @@ with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; @@ -50,6 +53,308 @@ with Validsw; use Validsw; package body Exp_Ch13 is + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Build_Predicate_Function + (Typ : Entity_Id; + FDecl : out Node_Id; + FBody : out Node_Id); + -- If Typ has predicates (indicated by Has_Predicates being set for Typ, + -- then either there are pragma Invariant entries on the rep chain for the + -- type (note that Predicate aspects are converted to pragam Predicate), or + -- there are inherited aspects from a parent type, or ancestor subtypes, + -- or interfaces. This procedure builds the spec and body for the Predicate + -- function that tests these predicates, returning them in PDecl and Pbody + -- and setting Predicate_Procedure for Typ. In some error situations no + -- procedure is built, in which case PDecl/PBody are empty on return. + + ------------------------------ + -- Build_Predicate_Function -- + ------------------------------ + + -- The procedure that is constructed here has the form + + -- function typPredicate (Ixxx : typ) return Boolean is + -- begin + -- return + -- exp1 and then exp2 and then ... + -- and then typ1Predicate (typ1 (Ixxx)) + -- and then typ2Predicate (typ2 (Ixxx)) + -- and then ...; + -- end typPredicate; + + -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that + -- this is the point at which these expressions get analyzed, providing the + -- required delay, and typ1, typ2, are entities from which predicates are + -- inherited. Note that we do NOT generate Check pragmas, that's because we + -- use this function even if checks are off, e.g. for membership tests. + + procedure Build_Predicate_Function + (Typ : Entity_Id; + FDecl : out Node_Id; + FBody : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (Typ); + Spec : Node_Id; + SId : Entity_Id; + + Expr : Node_Id; + -- This is the expression for the return statement in the function. It + -- is build by connecting the component predicates with AND THEN. + + procedure Add_Call (T : Entity_Id); + -- Includes a call statement to the predicate function for type T in + -- Expr if T has predicates and Predicate_Function (T) is non-empty. + + procedure Add_Predicates; + -- Appends expressions for any Predicate pragmas in the rep item chain + -- Typ to Expr. Note that we look only at items for this exact entity. + -- Inheritance of predicates for the parent type is done by calling the + -- Predicate_Function of the parent type, using Add_Call above. + + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of Predicate procedure + + -------------- + -- Add_Call -- + -------------- + + procedure Add_Call (T : Entity_Id) is + Exp : Node_Id; + + begin + if Present (T) + and then Present (Predicate_Function (T)) + then + Exp := + Make_Predicate_Call + (T, + Convert_To (T, + Make_Identifier (Loc, + Chars => Object_Name))); + + if No (Expr) then + Expr := Exp; + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Exp); + end if; + end if; + end Add_Call; + + -------------------- + -- Add_Predicates -- + -------------------- + + procedure Add_Predicates is + Ritem : Node_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; + + function Replace_Node (N : Node_Id) return Traverse_Result; + -- Process single node for traversal to replace type references + + procedure Replace_Type is new Traverse_Proc (Replace_Node); + -- Traverse an expression changing every occurrence of an entity + -- reference to type T with a reference to the object argument. + + ------------------ + -- Replace_Node -- + ------------------ + + function Replace_Node (N : Node_Id) return Traverse_Result is + begin + -- Case of entity name referencing the type + + if Is_Entity_Name (N) + and then Entity (N) = Typ + then + -- Replace with object + + Rewrite (N, + Make_Identifier (Loc, + Chars => Object_Name)); + + -- All done with this node + + return Skip; + + -- Not an instance of the type entity, keep going + + else + return OK; + end if; + end Replace_Node; + + begin + Ritem := First_Rep_Item (Typ); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Predicate + then + Arg1 := First (Pragma_Argument_Associations (Ritem)); + Arg2 := Next (Arg1); + + Arg1 := Get_Pragma_Arg (Arg1); + Arg2 := Get_Pragma_Arg (Arg2); + + -- We need to replace any occurrences of the name of the type + -- with references to the object. We do this by first doing a + -- preanalysis, to identify all the entities, then we traverse + -- looking for the type entity, doing the needed substitution. + -- The preanalysis is done with the special OK_To_Reference + -- flag set on the type, so that if we get an occurrence of + -- this type, it will be reognized as legitimate. + + Set_OK_To_Reference (Typ, True); + Preanalyze_Spec_Expression (Arg2, Standard_Boolean); + Set_OK_To_Reference (Typ, False); + Replace_Type (Arg2); + + -- See if this predicate pragma is for the current type + + if Entity (Arg1) = Typ then + + -- We have a match, add the expression + + if No (Expr) then + Expr := Relocate_Node (Arg2); + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Relocate_Node (Arg2)); + end if; + end if; + end if; + + Next_Rep_Item (Ritem); + end loop; + end Add_Predicates; + + -- Start of processing for Build_Predicate_Function + + begin + -- Initialize for construction of statement list + + Expr := Empty; + FDecl := Empty; + FBody := Empty; + + -- Return if already built or if type does not have predicates + + if not Has_Predicates (Typ) + or else Present (Predicate_Function (Typ)) + then + return; + end if; + + -- Add Predicates for the current type + + Add_Predicates; + + -- Deal with ancestor subtype and parent type + + declare + Atyp : constant Entity_Id := Ancestor_Subtype (Typ); + + begin + -- If ancestor subtype present, add its predicates + + if Present (Atyp) then + Add_Call (Atyp); + + -- Else if this is derived, add predicates of parent type + + elsif Is_Derived_Type (Typ) then + Add_Call (Etype (Base_Type (Typ))); + end if; + end; + + -- Add predicates of any interfaces of a tagged type + + if Is_Tagged_Type (Typ) then + declare + Iface_List : Elist_Id; + Elmt : Elmt_Id; + + begin + Collect_Interfaces (Typ, Iface_List); + + if Present (Iface_List) then + loop + Elmt := First_Elmt (Iface_List); + exit when No (Elmt); + Add_Call (Node (Elmt)); + Remove_Elmt (Iface_List, Elmt); + end loop; + end if; + end; + end if; + + if Present (Expr) then + + -- Build function declaration + + pragma Assert (Has_Predicates (Typ)); + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + Set_Has_Predicates (SId); + Set_Predicate_Function (Typ, SId); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); + + -- Build function body + + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Expr)))); + end if; + end Build_Predicate_Function; + ------------------------------------------ -- Expand_N_Attribute_Definition_Clause -- ------------------------------------------ @@ -414,6 +719,26 @@ package body Exp_Ch13 is Rewrite (N, Make_Null_Statement (Sloc (N))); end if; + -- If freezing a type entity which has predicates, this is where we + -- build and insert the predicate function for the type. + + if Is_Type (E) and then Has_Predicates (E) then + declare + FDecl : Node_Id; + FBody : Node_Id; + + begin + Build_Predicate_Function (E, FDecl, FBody); + + if Present (FDecl) then + Insert_After (N, FBody); + Insert_After (N, FDecl); + end if; + end; + end if; + + -- Pop scope if we intalled one for the analysis + if In_Other_Scope then if Ekind (Current_Scope) = E_Package then End_Package_Scope (E_Scope); |