-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
Process : not null access procedure (Position : Cursor));
private
-
-- A node of this multiway tree comprises an element and a list of children
-- (that are themselves trees). The root node is distinguished because it
-- contains only children: it does not have an element itself.
- --
- -- This design feature puts two design goals in tension:
+
+ -- This design feature puts two design goals in tension with one another:
-- (1) treat the root node the same as any other node
-- (2) not declare any objects of type Element_Type unnecessarily
- --
- -- To satisfy (1), we could simply declare the Root node of the tree using
- -- the normal Tree_Node_Type, but that would mean that (2) is not
+
+ -- To satisfy (1), we could simply declare the Root node of the tree
+ -- using the normal Tree_Node_Type, but that would mean that (2) is not
-- satisfied. To resolve the tension (in favor of (2)), we declare the
-- component Root as having a different node type, without an Element
-- component (thus satisfying goal (2)) but otherwise identical to a normal
-- normal, non-root node (thus satisfying goal (1)). We make an explicit
-- check for Root when there is any attempt to manipulate the Element
-- component of the node (a check required by the RM anyway).
- --
+
-- In order to be explicit about node (and pointer) representation, we
- -- specify that the respective node types have convention C, to ensure that
- -- the layout of the components of the node records is the same, thus
- -- guaranteeing that (unchecked) conversions between access types
+ -- specify that the respective node types have convention C, to ensure
+ -- that the layout of the components of the node records is the same,
+ -- thus guaranteeing that (unchecked) conversions between access types
-- designating each kind of node type is a meaningful conversion.
type Tree_Node_Type;
end record;
pragma Convention (C, Root_Node_Type);
+ for Root_Node_Type'Alignment use Standard'Maximum_Alignment;
+ -- The alignment has to be large enough to allow Root_Node to Tree_Node
+ -- access value conversions, and Tree_Node_Type's alignment may be bumped
+ -- up by the Element component.
+
use Ada.Finalization;
-- The Count component of type Tree represents the number of nodes that
Expression => New_Occurrence_Of (Obj_Id, Loc))));
end Build_Default_Init_Cond_Call;
- --------------------------------------------
- -- Build_Default_Init_Cond_Procedure_Body --
- --------------------------------------------
+ ----------------------------------------------
+ -- Build_Default_Init_Cond_Procedure_Bodies --
+ ----------------------------------------------
- procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
- Param_Id : Entity_Id;
- -- The entity of the formal parameter of the default initial condition
- -- procedure.
+ procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is
+ procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id);
+ -- If type Typ is subject to pragma Default_Initial_Condition, build the
+ -- body of the procedure which verifies the assumption of the pragma at
+ -- runtime. The generated body is added after the type declaration.
- procedure Replace_Type_Reference (N : Node_Id);
- -- Replace a single reference to type Typ with a reference to Param_Id
+ --------------------------------------------
+ -- Build_Default_Init_Cond_Procedure_Body --
+ --------------------------------------------
- ----------------------------
- -- Replace_Type_Reference --
- ----------------------------
+ procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
+ Param_Id : Entity_Id;
+ -- The entity of the sole formal parameter of the default initial
+ -- condition procedure.
- procedure Replace_Type_Reference (N : Node_Id) is
- begin
- Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
- end Replace_Type_Reference;
+ procedure Replace_Type_Reference (N : Node_Id);
+ -- Replace a single reference to type Typ with a reference to formal
+ -- parameter Param_Id.
- procedure Replace_Type_References is
- new Replace_Type_References_Generic (Replace_Type_Reference);
+ ----------------------------
+ -- Replace_Type_Reference --
+ ----------------------------
- -- Local variables
+ procedure Replace_Type_Reference (N : Node_Id) is
+ begin
+ Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
+ end Replace_Type_Reference;
- Loc : constant Source_Ptr := Sloc (Typ);
- Prag : constant Node_Id :=
- Get_Pragma (Typ, Pragma_Default_Initial_Condition);
- Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
- Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id);
- Body_Decl : Node_Id;
- Expr : Node_Id;
- Stmt : Node_Id;
+ procedure Replace_Type_References is
+ new Replace_Type_References_Generic (Replace_Type_Reference);
- -- Start of processing for Build_Default_Init_Cond_Procedure
+ -- Local variables
- begin
- -- The procedure should be generated only for types subject to pragma
- -- Default_Initial_Condition. Types that inherit the pragma do not get
- -- this specialized procedure.
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Prag : constant Node_Id :=
+ Get_Pragma (Typ, Pragma_Default_Initial_Condition);
+ Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
+ Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id);
+ Body_Decl : Node_Id;
+ Expr : Node_Id;
+ Stmt : Node_Id;
- pragma Assert (Has_Default_Init_Cond (Typ));
- pragma Assert (Present (Prag));
- pragma Assert (Present (Proc_Id));
+ -- Start of processing for Build_Default_Init_Cond_Procedure
- -- Nothing to do if the body was already built
+ begin
+ -- The procedure should be generated only for [sub]types subject to
+ -- pragma Default_Initial_Condition. Types that inherit the pragma do
+ -- not get this specialized procedure.
- if Present (Corresponding_Body (Spec_Decl)) then
- return;
- end if;
+ pragma Assert (Has_Default_Init_Cond (Typ));
+ pragma Assert (Present (Prag));
+ pragma Assert (Present (Proc_Id));
+
+ -- Nothing to do if the body was already built
+
+ if Present (Corresponding_Body (Spec_Decl)) then
+ return;
+ end if;
- Param_Id := First_Formal (Proc_Id);
+ Param_Id := First_Formal (Proc_Id);
- -- The pragma has an argument. Note that the argument is analyzed after
- -- all references to the current instance of the type are replaced.
+ -- The pragma has an argument. Note that the argument is analyzed
+ -- after all references to the current instance of the type are
+ -- replaced.
- if Present (Pragma_Argument_Associations (Prag)) then
- Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
+ if Present (Pragma_Argument_Associations (Prag)) then
+ Expr :=
+ Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
- if Nkind (Expr) = N_Null then
- Stmt := Make_Null_Statement (Loc);
+ if Nkind (Expr) = N_Null then
+ Stmt := Make_Null_Statement (Loc);
+
+ -- Preserve the original argument of the pragma by replicating it.
+ -- Replace all references to the current instance of the type with
+ -- references to the formal parameter.
+
+ else
+ Expr := New_Copy_Tree (Expr);
+ Replace_Type_References (Expr, Typ);
+
+ -- Generate:
+ -- pragma Check (Default_Initial_Condition, <Expr>);
+
+ Stmt :=
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Loc, Name_Check),
+
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Loc,
+ Chars => Name_Default_Initial_Condition)),
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Expr)));
+ end if;
- -- Preserve the original argument of the pragma by replicating it.
- -- Replace all references to the current instance of the type with
- -- references to the formal parameter.
+ -- Otherwise the pragma appears without an argument
else
- Expr := New_Copy_Tree (Expr);
- Replace_Type_References (Expr, Typ);
-
- -- Generate:
- -- pragma Check (Default_Initial_Condition, <Expr>);
-
- Stmt :=
- Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Loc, Name_Check),
-
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Loc, Name_Default_Initial_Condition)),
- Make_Pragma_Argument_Association (Loc,
- Expression => Expr)));
+ Stmt := Make_Null_Statement (Loc);
end if;
- -- Otherwise the pragma appears without an argument
+ -- Generate:
+ -- procedure <Typ>Default_Init_Cond (I : <Typ>) is
+ -- begin
+ -- <Stmt>;
+ -- end <Typ>Default_Init_Cond;
- else
- Stmt := Make_Null_Statement (Loc);
- end if;
+ Body_Decl :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Separate_Tree (Specification (Spec_Decl)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Stmt)));
- -- Generate:
- -- procedure <Typ>Default_Init_Cond (I : <Typ>) is
- -- begin
- -- <Stmt>;
- -- end <Typ>Default_Init_Cond;
-
- Body_Decl :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Separate_Tree (Specification (Spec_Decl)),
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Stmt)));
-
- -- Link the spec and body of the default initial condition procedure
- -- to prevent the generation of a duplicate body in case there is an
- -- attempt to freeze the related type again.
-
- Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
- Set_Corresponding_Spec (Body_Decl, Proc_Id);
-
- Append_Freeze_Action (Typ, Body_Decl);
- end Build_Default_Init_Cond_Procedure_Body;
+ -- Link the spec and body of the default initial condition procedure
+ -- to prevent the generation of a duplicate body.
+
+ Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
+ Set_Corresponding_Spec (Body_Decl, Proc_Id);
+
+ Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl);
+ end Build_Default_Init_Cond_Procedure_Body;
+
+ -- Local variables
+
+ Decl : Node_Id;
+ Typ : Entity_Id;
+
+ -- Start of processing for Build_Default_Init_Cond_Procedure_Bodies
+
+ begin
+ -- Inspect the private declarations looking for [sub]type declarations
+
+ Decl := First (Priv_Decls);
+ while Present (Decl) loop
+ if Nkind_In (Decl, N_Full_Type_Declaration,
+ N_Subtype_Declaration)
+ then
+ Typ := Defining_Entity (Decl);
+
+ -- Guard against partially decorate types due to previous errors
+
+ if Is_Type (Typ) then
+
+ -- If the type is subject to pragma Default_Initial_Condition,
+ -- generate the body of the internal procedure which verifies
+ -- the assertion of the pragma at runtime.
+
+ if Has_Default_Init_Cond (Typ) then
+ Build_Default_Init_Cond_Procedure_Body (Typ);
+
+ -- A derived type inherits the default initial condition
+ -- procedure from its parent type.
+
+ elsif Has_Inherited_Default_Init_Cond (Typ) then
+ Inherit_Default_Init_Cond_Procedure (Typ);
+ end if;
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Build_Default_Init_Cond_Procedure_Bodies;
---------------------------------------------------
-- Build_Default_Init_Cond_Procedure_Declaration --
projects / thirdparty / gcc.git / commitdiff
