with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Disp; use Exp_Disp;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Prag; use Sem_Prag;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Strub; use Strub;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
-- Attribute references to outer types are freeze points for those types;
-- this routine generates the required freeze nodes for them.
- procedure Check_Inherited_Conditions (R : Entity_Id);
- -- For a tagged derived type, create wrappers for inherited operations
- -- that have a class-wide condition, so it can be properly rewritten if
- -- it involves calls to other overriding primitives.
-
procedure Check_Strict_Alignment (E : Entity_Id);
-- E is a base type. If E is tagged or has a component that is aliased
-- or tagged or contains something this is aliased or tagged, set
procedure Freeze_Enumeration_Type (Typ : Entity_Id);
-- Freeze enumeration type. The Esize field is set as processing
-- proceeds (i.e. set by default when the type is declared and then
- -- adjusted by rep clauses. What this procedure does is to make sure
+ -- adjusted by rep clauses). What this procedure does is to make sure
-- that if a foreign convention is specified, and no specific size
-- is given, then the size must be at least Integer'Size.
-- Full_View or Corresponding_Record_Type.
procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id);
- -- Expr is the expression for an address clause for entity Nam whose type
- -- is Typ. If Typ has a default initialization, and there is no explicit
- -- initialization in the source declaration, check whether the address
- -- clause might cause overlaying of an entity, and emit a warning on the
- -- side effect that the initialization will cause.
+ -- Expr is the expression for an address clause for the entity denoted by
+ -- Nam whose type is Typ. If Typ has a default initialization, and there is
+ -- no explicit initialization in the source declaration, check whether the
+ -- address clause might cause overlaying of an entity, and emit a warning
+ -- on the side effect that the initialization will cause.
-------------------------------
-- Adjust_Esize_For_Alignment --
Next (Param_Spec);
end loop;
- Body_Node :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call_Node)));
+ -- In GNATprove, prefer to generate an expression function whenever
+ -- possible, to benefit from the more precise analysis in that case
+ -- (as if an implicit postcondition had been generated).
+
+ if GNATprove_Mode
+ and then Nkind (Call_Node) = N_Simple_Return_Statement
+ then
+ Body_Node :=
+ Make_Expression_Function (Loc,
+ Specification => Spec,
+ Expression => Expression (Call_Node));
+ else
+ Body_Node :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call_Node)));
+ end if;
if Nkind (Decl) /= N_Subprogram_Declaration then
Rewrite (N,
Error_Msg_NE (Size_Too_Small_Message, Size_Clause (T), T);
end if;
- -- Set size if not set already
+ -- Set size if not set already. Do not set it to Uint_0, because in
+ -- some cases (notably array-of-record), the Component_Size is
+ -- No_Uint, which causes S to be Uint_0. Presumably the RM_Size and
+ -- Component_Size will eventually be set correctly by the back end.
- elsif Unknown_RM_Size (T) then
+ elsif not Known_RM_Size (T) and then S /= Uint_0 then
Set_RM_Size (T, S);
end if;
end Set_Small_Size;
-- String literals always have known size, and we can set it
if Ekind (T) = E_String_Literal_Subtype then
- Set_Small_Size
- (T, Component_Size (T) * String_Literal_Length (T));
+ if Known_Component_Size (T) then
+ Set_Small_Size
+ (T, Component_Size (T) * String_Literal_Length (T));
+
+ else
+ -- The following is wrong, but does what previous versions
+ -- did. The Component_Size is unknown for the string in a
+ -- pragma Warnings.
+ Set_Small_Size (T, Uint_0);
+ end if;
+
return True;
-- Unconstrained types never have known at compile time size
Dim : Uint;
begin
+ -- See comment in Set_Small_Size above
+
+ if No (Size) then
+ Size := Uint_0;
+ end if;
+
Index := First_Index (T);
while Present (Index) loop
if Nkind (Index) = N_Range then
else
Dim := Expr_Value (High) - Expr_Value (Low) + 1;
- if Dim >= 0 then
+ if Dim > Uint_0 then
Size := Size * Dim;
else
Size := Uint_0;
if not Is_Constrained (T)
and then
No (Discriminant_Default_Value (First_Discriminant (T)))
- and then Unknown_RM_Size (T)
+ and then not Known_RM_Size (T)
then
return False;
end if;
if Present (Component_Clause (Comp)) then
Comp_Byte_Aligned :=
- (Normalized_First_Bit (Comp) mod System_Storage_Unit = 0)
+ Known_Normalized_First_Bit (Comp)
and then
- (Esize (Comp) mod System_Storage_Unit = 0);
+ Known_Esize (Comp)
+ and then
+ Normalized_First_Bit (Comp) mod System_Storage_Unit = 0
+ and then
+ Esize (Comp) mod System_Storage_Unit = 0;
else
Comp_Byte_Aligned := not Is_Packed (Encl_Type);
end if;
elsif Is_Record_Type (Encl_Base)
and then not Comp_Byte_Aligned
then
- Error_Msg_N
- ("type of non-byte-aligned component must have same scalar "
- & "storage order as enclosing composite", Err_Node);
+ if Present (Component_Clause (Comp)) then
+ Error_Msg_N
+ ("type of non-byte-aligned component must have same scalar"
+ & " storage order as enclosing record", Err_Node);
+ else
+ Error_Msg_N
+ ("type of packed component must have same scalar"
+ & " storage order as enclosing record", Err_Node);
+ end if;
-- Warn if specified only for the outer composite
-- Check_Inherited_Conditions --
--------------------------------
- procedure Check_Inherited_Conditions (R : Entity_Id) is
- Prim_Ops : constant Elist_Id := Primitive_Operations (R);
- Decls : List_Id;
- Needs_Wrapper : Boolean;
- Op_Node : Elmt_Id;
- Par_Prim : Entity_Id;
- Prim : Entity_Id;
-
- procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id);
+ procedure Check_Inherited_Conditions
+ (R : Entity_Id;
+ Late_Overriding : Boolean := False)
+ is
+ Prim_Ops : constant Elist_Id := Primitive_Operations (R);
+ Decls : List_Id;
+ Op_Node : Elmt_Id;
+ Par_Prim : Entity_Id;
+ Prim : Entity_Id;
+ Wrapper_Needed : Boolean;
+
+ function Build_DTW_Body
+ (Loc : Source_Ptr;
+ DTW_Spec : Node_Id;
+ DTW_Decls : List_Id;
+ Par_Prim : Entity_Id;
+ Wrapped_Subp : Entity_Id) return Node_Id;
+ -- Build the body of the dispatch table wrapper containing the given
+ -- spec and declarations; the call to the wrapped subprogram includes
+ -- the proper type conversion.
+
+ function Build_DTW_Spec (Par_Prim : Entity_Id) return Node_Id;
+ -- Build the spec of the dispatch table wrapper
+
+ procedure Build_Inherited_Condition_Pragmas
+ (Subp : Entity_Id;
+ Wrapper_Needed : out Boolean);
-- Build corresponding pragmas for an operation whose ancestor has
- -- class-wide pre/postconditions. If the operation is inherited, the
- -- pragmas force the creation of a wrapper for the inherited operation.
- -- If the ancestor is being overridden, the pragmas are constructed only
- -- to verify their legality, in case they contain calls to other
- -- primitives that may have been overridden.
+ -- class-wide pre/postconditions. If the operation is inherited then
+ -- Wrapper_Needed is returned True to force the creation of a wrapper
+ -- for the inherited operation. If the ancestor is being overridden,
+ -- the pragmas are constructed only to verify their legality, in case
+ -- they contain calls to other primitives that may have been overridden.
+
+ function Needs_Wrapper
+ (Class_Cond : Node_Id;
+ Subp : Entity_Id;
+ Par_Subp : Entity_Id) return Boolean;
+ -- Checks whether the dispatch-table wrapper (DTW) for Subp must be
+ -- built to evaluate the given class-wide condition.
+
+ --------------------
+ -- Build_DTW_Body --
+ --------------------
+
+ function Build_DTW_Body
+ (Loc : Source_Ptr;
+ DTW_Spec : Node_Id;
+ DTW_Decls : List_Id;
+ Par_Prim : Entity_Id;
+ Wrapped_Subp : Entity_Id) return Node_Id
+ is
+ Par_Typ : constant Entity_Id := Find_Dispatching_Type (Par_Prim);
+ Actuals : constant List_Id := Empty_List;
+ Call : Node_Id;
+ Formal : Entity_Id := First_Formal (Par_Prim);
+ New_F_Spec : Entity_Id := First (Parameter_Specifications (DTW_Spec));
+ New_Formal : Entity_Id;
+
+ begin
+ -- Build parameter association for call to wrapped subprogram
+
+ while Present (Formal) loop
+ New_Formal := Defining_Identifier (New_F_Spec);
+
+ -- If the controlling argument is inherited, add conversion to
+ -- parent type for the call.
+
+ if Etype (Formal) = Par_Typ
+ and then Is_Controlling_Formal (Formal)
+ then
+ Append_To (Actuals,
+ Make_Type_Conversion (Loc,
+ New_Occurrence_Of (Par_Typ, Loc),
+ New_Occurrence_Of (New_Formal, Loc)));
+ else
+ Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
+ end if;
+
+ Next_Formal (Formal);
+ Next (New_F_Spec);
+ end loop;
+
+ if Ekind (Wrapped_Subp) = E_Procedure then
+ Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Wrapped_Subp, Loc),
+ Parameter_Associations => Actuals);
+ else
+ Call :=
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Wrapped_Subp, Loc),
+ Parameter_Associations => Actuals));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification => Copy_Subprogram_Spec (DTW_Spec),
+ Declarations => DTW_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call),
+ End_Label => Make_Identifier (Loc,
+ Chars (Defining_Entity (DTW_Spec)))));
+ end Build_DTW_Body;
+
+ --------------------
+ -- Build_DTW_Spec --
+ --------------------
+
+ function Build_DTW_Spec (Par_Prim : Entity_Id) return Node_Id is
+ DTW_Id : Entity_Id;
+ DTW_Spec : Node_Id;
+
+ begin
+ DTW_Spec := Build_Overriding_Spec (Par_Prim, R);
+ DTW_Id := Defining_Entity (DTW_Spec);
+
+ -- Add minimal decoration of fields
+
+ Mutate_Ekind (DTW_Id, Ekind (Par_Prim));
+ Set_LSP_Subprogram (DTW_Id, Par_Prim);
+ Set_Is_Dispatch_Table_Wrapper (DTW_Id);
+ Set_Is_Wrapper (DTW_Id);
+
+ -- The DTW wrapper is never a null procedure
+
+ if Nkind (DTW_Spec) = N_Procedure_Specification then
+ Set_Null_Present (DTW_Spec, False);
+ end if;
+
+ return DTW_Spec;
+ end Build_DTW_Spec;
---------------------------------------
-- Build_Inherited_Condition_Pragmas --
---------------------------------------
- procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id) is
- A_Post : Node_Id;
- A_Pre : Node_Id;
- New_Prag : Node_Id;
+ procedure Build_Inherited_Condition_Pragmas
+ (Subp : Entity_Id;
+ Wrapper_Needed : out Boolean)
+ is
+ Class_Pre : constant Node_Id :=
+ Class_Preconditions (Ultimate_Alias (Subp));
+ Class_Post : Node_Id := Class_Postconditions (Par_Prim);
+ A_Post : Node_Id;
+ New_Prag : Node_Id;
begin
- A_Pre := Get_Class_Wide_Pragma (Par_Prim, Pragma_Precondition);
+ Wrapper_Needed := False;
- if Present (A_Pre) then
- New_Prag := New_Copy_Tree (A_Pre);
- Build_Class_Wide_Expression
- (Prag => New_Prag,
- Subp => Prim,
- Par_Subp => Par_Prim,
- Adjust_Sloc => False,
- Needs_Wrapper => Needs_Wrapper);
-
- if Needs_Wrapper
- and then not Comes_From_Source (Subp)
- and then Expander_Active
- then
- Append (New_Prag, Decls);
- end if;
+ if No (Class_Pre) and then No (Class_Post) then
+ return;
end if;
- A_Post := Get_Class_Wide_Pragma (Par_Prim, Pragma_Postcondition);
+ -- For class-wide preconditions we just evaluate whether the wrapper
+ -- is needed; there is no need to build the pragma since the check
+ -- is performed on the caller side.
- if Present (A_Post) then
- New_Prag := New_Copy_Tree (A_Post);
+ if Present (Class_Pre)
+ and then Needs_Wrapper (Class_Pre, Subp, Par_Prim)
+ then
+ Wrapper_Needed := True;
+ end if;
+
+ -- For class-wide postconditions we evaluate whether the wrapper is
+ -- needed and we build the class-wide postcondition pragma to install
+ -- it in the wrapper.
+
+ if Present (Class_Post)
+ and then Needs_Wrapper (Class_Post, Subp, Par_Prim)
+ then
+ Wrapper_Needed := True;
+
+ -- Update the class-wide postcondition
+
+ Class_Post := New_Copy_Tree (Class_Post);
Build_Class_Wide_Expression
- (Prag => New_Prag,
- Subp => Prim,
+ (Pragma_Or_Expr => Class_Post,
+ Subp => Subp,
Par_Subp => Par_Prim,
- Adjust_Sloc => False,
- Needs_Wrapper => Needs_Wrapper);
+ Adjust_Sloc => False);
- if Needs_Wrapper
- and then not Comes_From_Source (Subp)
- and then Expander_Active
- then
- Append (New_Prag, Decls);
+ -- Install the updated class-wide postcondition in a copy of the
+ -- pragma postcondition defined for the nearest ancestor.
+
+ A_Post := Get_Class_Wide_Pragma (Par_Prim,
+ Pragma_Postcondition);
+
+ if No (A_Post) then
+ declare
+ Subps : constant Subprogram_List :=
+ Inherited_Subprograms (Subp);
+ begin
+ for Index in Subps'Range loop
+ A_Post := Get_Class_Wide_Pragma (Subps (Index),
+ Pragma_Postcondition);
+ exit when Present (A_Post);
+ end loop;
+ end;
end if;
+
+ New_Prag := New_Copy_Tree (A_Post);
+ Rewrite
+ (Expression (First (Pragma_Argument_Associations (New_Prag))),
+ Class_Post);
+ Append (New_Prag, Decls);
end if;
end Build_Inherited_Condition_Pragmas;
+ -------------------
+ -- Needs_Wrapper --
+ -------------------
+
+ function Needs_Wrapper
+ (Class_Cond : Node_Id;
+ Subp : Entity_Id;
+ Par_Subp : Entity_Id) return Boolean
+ is
+ Result : Boolean := False;
+
+ function Check_Entity (N : Node_Id) return Traverse_Result;
+ -- Check calls to overridden primitives
+
+ --------------------
+ -- Replace_Entity --
+ --------------------
+
+ function Check_Entity (N : Node_Id) return Traverse_Result is
+ New_E : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+ and then
+ (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
+ and then
+ (Nkind (Parent (N)) /= N_Attribute_Reference
+ or else Attribute_Name (Parent (N)) /= Name_Class)
+ then
+ -- The check does not apply to dispatching calls within the
+ -- condition, but only to calls whose static tag is that of
+ -- the parent type.
+
+ if Is_Subprogram (Entity (N))
+ and then Nkind (Parent (N)) = N_Function_Call
+ and then Present (Controlling_Argument (Parent (N)))
+ then
+ return OK;
+ end if;
+
+ -- Determine whether entity has a renaming
+
+ New_E := Get_Mapped_Entity (Entity (N));
+
+ -- If the entity is an overridden primitive and we are not
+ -- in GNATprove mode, we must build a wrapper for the current
+ -- inherited operation. If the reference is the prefix of an
+ -- attribute such as 'Result (or others ???) there is no need
+ -- for a wrapper: the condition is just rewritten in terms of
+ -- the inherited subprogram.
+
+ if Present (New_E)
+ and then Comes_From_Source (New_E)
+ and then Is_Subprogram (New_E)
+ and then Nkind (Parent (N)) /= N_Attribute_Reference
+ and then not GNATprove_Mode
+ then
+ Result := True;
+ return Abandon;
+ end if;
+ end if;
+
+ return OK;
+ end Check_Entity;
+
+ procedure Check_Condition_Entities is
+ new Traverse_Proc (Check_Entity);
+
+ -- Start of processing for Needs_Wrapper
+
+ begin
+ Update_Primitives_Mapping (Par_Subp, Subp);
+
+ Map_Formals (Par_Subp, Subp);
+ Check_Condition_Entities (Class_Cond);
+
+ return Result;
+ end Needs_Wrapper;
+
+ Ifaces_List : Elist_Id := No_Elist;
+ Ifaces_Listed : Boolean := False;
+ -- Cache the list of interface operations inherited by R
+
-- Start of processing for Check_Inherited_Conditions
begin
- Op_Node := First_Elmt (Prim_Ops);
- while Present (Op_Node) loop
- Prim := Node (Op_Node);
+ if Late_Overriding then
+ Op_Node := First_Elmt (Prim_Ops);
+ while Present (Op_Node) loop
+ Prim := Node (Op_Node);
- -- Map the overridden primitive to the overriding one. This takes
- -- care of all overridings and is done only once.
+ -- Map the overridden primitive to the overriding one
- if Present (Overridden_Operation (Prim))
- and then Comes_From_Source (Prim)
- then
- Par_Prim := Overridden_Operation (Prim);
- Update_Primitives_Mapping (Par_Prim, Prim);
- end if;
+ if Present (Overridden_Operation (Prim))
+ and then Comes_From_Source (Prim)
+ then
+ Par_Prim := Overridden_Operation (Prim);
+ Update_Primitives_Mapping (Par_Prim, Prim);
- Next_Elmt (Op_Node);
- end loop;
+ -- Force discarding previous mappings of its formals
+
+ Map_Formals (Par_Prim, Prim, Force_Update => True);
+ end if;
+
+ Next_Elmt (Op_Node);
+ end loop;
+ end if;
-- Perform validity checks on the inherited conditions of overriding
-- operations, for conformance with LSP, and apply SPARK-specific
while Present (Op_Node) loop
Prim := Node (Op_Node);
- if Present (Overridden_Operation (Prim))
+ Par_Prim := Overridden_Operation (Prim);
+ if Present (Par_Prim)
and then Comes_From_Source (Prim)
then
- Par_Prim := Overridden_Operation (Prim);
-
-- When the primitive is an LSP wrapper we climb to the parent
-- primitive that has the inherited contract.
Par_Prim := LSP_Subprogram (Par_Prim);
end if;
+ -- Check that overrider and overridden operations have
+ -- the same strub mode.
+
+ Check_Same_Strub_Mode (Prim, Par_Prim);
+
-- Analyze the contract items of the overridden operation, before
-- they are rewritten as pragmas.
if GNATprove_Mode then
Collect_Inherited_Class_Wide_Conditions (Prim);
+ end if;
+ end if;
- -- Otherwise build the corresponding pragmas to check for legality
- -- of the inherited condition.
+ -- Go over operations inherited from interfaces and check
+ -- them for strub mode compatibility as well.
- else
- Build_Inherited_Condition_Pragmas (Prim);
- end if;
+ if Has_Interfaces (R)
+ and then Is_Dispatching_Operation (Prim)
+ and then Find_Dispatching_Type (Prim) = R
+ then
+ declare
+ Elmt : Elmt_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Prim : Entity_Id;
+
+ begin
+ -- Collect the interfaces only once. We haven't
+ -- finished freezing yet, so we can't use the faster
+ -- search from Sem_Disp.Covered_Interface_Primitives.
+
+ if not Ifaces_Listed then
+ Collect_Interfaces (R, Ifaces_List);
+ Ifaces_Listed := True;
+ end if;
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Elmt) loop
+ Iface_Prim := Node (Elmt);
+
+ if Iface_Prim /= Par_Prim
+ and then Chars (Iface_Prim) = Chars (Prim)
+ and then Comes_From_Source (Iface_Prim)
+ and then (Is_Interface_Conformant
+ (R, Iface_Prim, Prim))
+ then
+ Check_Same_Strub_Mode (Prim, Iface_Prim);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end;
end if;
Next_Elmt (Op_Node);
Op_Node := First_Elmt (Prim_Ops);
while Present (Op_Node) loop
- Decls := Empty_List;
- Prim := Node (Op_Node);
- Needs_Wrapper := False;
+ Decls := Empty_List;
+ Prim := Node (Op_Node);
+ Wrapper_Needed := False;
- if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then
- Par_Prim := Alias (Prim);
+ -- Skip internal entities built for mapping interface primitives
+
+ if not Comes_From_Source (Prim)
+ and then Present (Alias (Prim))
+ and then No (Interface_Alias (Prim))
+ then
+ Par_Prim := Ultimate_Alias (Prim);
-- When the primitive is an LSP wrapper we climb to the parent
-- primitive that has the inherited contract.
-- in the loop above.
Analyze_Entry_Or_Subprogram_Contract (Par_Prim);
- Build_Inherited_Condition_Pragmas (Prim);
+ Build_Inherited_Condition_Pragmas (Prim, Wrapper_Needed);
end if;
- if Needs_Wrapper
+ if Wrapper_Needed
and then not Is_Abstract_Subprogram (Par_Prim)
and then Expander_Active
then
- -- We need to build a new primitive that overrides the inherited
- -- one, and whose inherited expression has been updated above.
- -- These expressions are the arguments of pragmas that are part
- -- of the declarations of the wrapper. The wrapper holds a single
- -- statement that is a call to the class-wide clone, where the
- -- controlling actuals are conversions to the corresponding type
- -- in the parent primitive:
-
- -- procedure New_Prim (F1 : T1; ...);
- -- procedure New_Prim (F1 : T1; ...) is
- -- pragma Check (Precondition, Expr);
- -- begin
- -- Par_Prim_Clone (Par_Type (F1), ...);
- -- end;
-
- -- If the primitive is a function the statement is a return
- -- statement with a call.
+ -- Build the dispatch-table wrapper (DTW). The support for
+ -- AI12-0195 relies on two kind of wrappers: one for indirect
+ -- calls (also used for AI12-0220), and one for putting in the
+ -- dispatch table:
+ --
+ -- 1) "indirect-call wrapper" (ICW) is needed anytime there are
+ -- class-wide preconditions. Prim'Access will point directly
+ -- at the ICW if any, or at the "pristine" body if Prim has
+ -- no class-wide preconditions.
+ --
+ -- 2) "dispatch-table wrapper" (DTW) is needed anytime the class
+ -- wide preconditions *or* the class-wide postconditions are
+ -- affected by overriding.
+ --
+ -- The DTW holds a single statement that is a single call where
+ -- the controlling actuals are conversions to the corresponding
+ -- type in the parent primitive. If the primitive is a function
+ -- the statement is a return statement with a call.
declare
Alias_Id : constant Entity_Id := Ultimate_Alias (Prim);
Loc : constant Source_Ptr := Sloc (R);
- Par_R : constant Node_Id := Parent (R);
- New_Body : Node_Id;
- New_Decl : Node_Id;
- New_Id : Entity_Id;
- New_Spec : Node_Id;
+ DTW_Body : Node_Id;
+ DTW_Decl : Node_Id;
+ DTW_Id : Entity_Id;
+ DTW_Spec : Node_Id;
begin
-- The wrapper must be analyzed in the scope of its wrapped
Push_Scope (Scope (Prim));
- New_Spec := Build_Overriding_Spec (Par_Prim, R);
- New_Id := Defining_Entity (New_Spec);
- New_Decl :=
- Make_Subprogram_Declaration (Loc,
- Specification => New_Spec);
+ DTW_Spec := Build_DTW_Spec (Par_Prim);
+ DTW_Id := Defining_Entity (DTW_Spec);
+ DTW_Decl := Make_Subprogram_Declaration (Loc,
+ Specification => DTW_Spec);
+
+ -- For inherited class-wide preconditions the DTW wrapper
+ -- reuses the ICW of the parent (which checks the parent
+ -- interpretation of the class-wide preconditions); the
+ -- interpretation of the class-wide preconditions for the
+ -- inherited subprogram is checked at the caller side.
+
+ -- When the subprogram inherits class-wide postconditions
+ -- the DTW also checks the interpretation of the class-wide
+ -- postconditions for the inherited subprogram, and the body
+ -- of the parent checks its interpretation of the parent for
+ -- the class-wide postconditions.
+
+ -- procedure Prim (F1 : T1; ...) is
+ -- [ pragma Check (Postcondition, Expr); ]
+ -- begin
+ -- Par_Prim_ICW (Par_Type (F1), ...);
+ -- end;
+
+ if Present (Indirect_Call_Wrapper (Par_Prim)) then
+ DTW_Body :=
+ Build_DTW_Body (Loc,
+ DTW_Spec => DTW_Spec,
+ DTW_Decls => Decls,
+ Par_Prim => Par_Prim,
+ Wrapped_Subp => Indirect_Call_Wrapper (Par_Prim));
+
+ -- For subprograms that only inherit class-wide postconditions
+ -- the DTW wrapper calls the parent primitive (which on its
+ -- body checks the interpretation of the class-wide post-
+ -- conditions for the parent subprogram), and the DTW checks
+ -- the interpretation of the class-wide postconditions for the
+ -- inherited subprogram.
+
+ -- procedure Prim (F1 : T1; ...) is
+ -- pragma Check (Postcondition, Expr);
+ -- begin
+ -- Par_Prim (Par_Type (F1), ...);
+ -- end;
- -- Insert the declaration and the body of the wrapper after
- -- type declaration that generates inherited operation. For
- -- a null procedure, the declaration implies a null body.
+ else
+ DTW_Body :=
+ Build_DTW_Body (Loc,
+ DTW_Spec => DTW_Spec,
+ DTW_Decls => Decls,
+ Par_Prim => Par_Prim,
+ Wrapped_Subp => Par_Prim);
+ end if;
- if Nkind (New_Spec) = N_Procedure_Specification
- and then Null_Present (New_Spec)
- then
- Insert_After_And_Analyze (Par_R, New_Decl);
+ -- Insert the declaration of the wrapper before the freezing
+ -- node of the record type declaration to ensure that it will
+ -- override the internal primitive built by Derive_Subprogram.
+ if Late_Overriding then
+ Ensure_Freeze_Node (R);
+ Insert_Before_And_Analyze (Freeze_Node (R), DTW_Decl);
else
- -- Build body as wrapper to a call to the already built
- -- class-wide clone.
+ Append_Freeze_Action (R, DTW_Decl);
+ end if;
+
+ Analyze (DTW_Decl);
+
+ -- Insert the body of the wrapper in the freeze actions of
+ -- its record type declaration to ensure that it is placed
+ -- in the scope of its declaration but not too early to cause
+ -- premature freezing of other entities.
+
+ Append_Freeze_Action (R, DTW_Body);
+ Analyze (DTW_Body);
- New_Body :=
- Build_Class_Wide_Clone_Call
- (Loc, Decls, Par_Prim, New_Spec);
+ -- Ensure correct decoration
- -- Adding minimum decoration
+ pragma Assert (Is_Dispatching_Operation (DTW_Id));
+ pragma Assert (Present (Overridden_Operation (DTW_Id)));
+ pragma Assert (Overridden_Operation (DTW_Id) = Alias_Id);
- Mutate_Ekind (New_Id, Ekind (Par_Prim));
- Set_LSP_Subprogram (New_Id, Par_Prim);
- Set_Is_Wrapper (New_Id);
+ -- Inherit dispatch table slot
- Insert_List_After_And_Analyze
- (Par_R, New_List (New_Decl, New_Body));
+ Set_DTC_Entity_Value (R, DTW_Id);
+ Set_DT_Position (DTW_Id, DT_Position (Alias_Id));
- -- Ensure correct decoration
+ -- Register the wrapper in the dispatch table
- pragma Assert (Present (Alias (Prim)));
- pragma Assert (Present (Overridden_Operation (New_Id)));
- pragma Assert (Overridden_Operation (New_Id) = Alias_Id);
+ if Late_Overriding
+ and then not Building_Static_DT (R)
+ then
+ Insert_List_After_And_Analyze (Freeze_Node (R),
+ Register_Primitive (Loc, DTW_Id));
end if;
- pragma Assert (Is_Dispatching_Operation (Prim));
- pragma Assert (Is_Dispatching_Operation (New_Id));
+ -- Build the helper and ICW for the DTW
+
+ if Present (Indirect_Call_Wrapper (Par_Prim)) then
+ declare
+ CW_Subp : Entity_Id;
+ Decl_N : Node_Id;
+ Body_N : Node_Id;
+
+ begin
+ Merge_Class_Conditions (DTW_Id);
+ Make_Class_Precondition_Subps (DTW_Id,
+ Late_Overriding => Late_Overriding);
+
+ CW_Subp := Static_Call_Helper (DTW_Id);
+ Decl_N := Unit_Declaration_Node (CW_Subp);
+ Analyze (Decl_N);
+
+ -- If the DTW was built for a late-overriding primitive
+ -- its body must be analyzed now (since the tagged type
+ -- is already frozen).
+
+ if Late_Overriding then
+ Body_N :=
+ Unit_Declaration_Node
+ (Corresponding_Body (Decl_N));
+ Analyze (Body_N);
+ end if;
+ end;
+ end if;
Pop_Scope;
end;
-- created for entry parameters must be frozen.
if Ekind (E) = E_Package
- and then No (Renamed_Object (E))
+ and then No (Renamed_Entity (E))
and then not Is_Child_Unit (E)
and then not Is_Frozen (E)
then
Process_Default_Expressions (E, After);
end if;
+ -- Check subprogram renamings for the same strub-mode.
+ -- Avoid rechecking dispatching operations, that's taken
+ -- care of in Check_Inherited_Conditions, that covers
+ -- inherited interface operations.
+
+ Item := Alias (E);
+ if Present (Item)
+ and then not Is_Dispatching_Operation (E)
+ then
+ Check_Same_Strub_Mode (E, Item);
+ end if;
+
if not Has_Completion (E) then
Decl := Unit_Declaration_Node (E);
Error_Msg_Uint_1 := Modv;
Error_Msg_N
- ("?M?2 '*'*^' may have been intended here",
+ ("?.m?2 '*'*^' may have been intended here",
Modulus);
end;
end if;
-- cases of types whose alignment exceeds their size (the
-- padded type cases).
- if Csiz /= 0 then
+ if Csiz /= 0 and then Known_Alignment (Ctyp) then
declare
A : constant Uint := Alignment_In_Bits (Ctyp);
begin
if Has_Pragma_Pack (Arr)
and then not Present (Comp_Size_C)
and then (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
+ and then Known_Esize (Base_Type (Ctyp))
and then Esize (Base_Type (Ctyp)) = Csiz + 1
then
Error_Msg_Uint_1 := Csiz;
-- Processing that is done only for subtypes
else
- -- Acquire alignment from base type
+ -- Acquire alignment from base type. Known_Alignment of the base
+ -- type is False for Wide_String, for example.
- if Unknown_Alignment (Arr) then
+ if not Known_Alignment (Arr)
+ and then Known_Alignment (Base_Type (Arr))
+ then
Set_Alignment (Arr, Alignment (Base_Type (Arr)));
Adjust_Esize_Alignment (Arr);
end if;
(No (Ancestor_Subtype (Arr))
or else not Has_Size_Clause (Ancestor_Subtype (Arr)))
then
- Set_Esize (Arr, Esize (Packed_Array_Impl_Type (Arr)));
- Set_RM_Size (Arr, RM_Size (Packed_Array_Impl_Type (Arr)));
+ Copy_Esize (To => Arr, From => Packed_Array_Impl_Type (Arr));
+ Copy_RM_Size (To => Arr, From => Packed_Array_Impl_Type (Arr));
end if;
if not Has_Alignment_Clause (Arr) then
- Set_Alignment (Arr, Alignment (Packed_Array_Impl_Type (Arr)));
+ Copy_Alignment
+ (To => Arr, From => Packed_Array_Impl_Type (Arr));
end if;
end if;
-- active.
if Is_Access_Type (F_Type)
+ and then Known_Esize (F_Type)
and then Esize (F_Type) > Ttypes.System_Address_Size
and then (not Unnest_Subprogram_Mode
or else not Is_Access_Subprogram_Type (F_Type))
-- Check suspicious return of fat C pointer
if Is_Access_Type (R_Type)
+ and then Known_Esize (R_Type)
and then Esize (R_Type) > Ttypes.System_Address_Size
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
-- to the components of Rec.
begin
- Comp := First_Entity (E);
+ Comp := First_Component (E);
while Present (Comp) loop
- if Ekind (Comp) = E_Component
- and then Has_Delayed_Aspects (Comp)
- then
+ if Has_Delayed_Aspects (Comp) then
if not Rec_Pushed then
Push_Scope (E);
Rec_Pushed := True;
Analyze_Aspects_At_Freeze_Point (Comp);
end if;
- Next_Entity (Comp);
+ Next_Component (Comp);
end loop;
-- Pop the scope if Rec scope has been pushed on the scope stack
then
Error_Msg_NE
("useless postcondition, & is marked "
- & "No_Return?T?", Exp, E);
+ & "No_Return?.t?", Exp, E);
end if;
end if;
if Is_Array_Type (E) then
declare
Ctyp : constant Entity_Id := Component_Type (E);
- Rsiz : constant Uint := RM_Size (Ctyp);
+ Rsiz : constant Uint :=
+ (if Known_RM_Size (Ctyp) then RM_Size (Ctyp) else Uint_0);
SZ : constant Node_Id := Size_Clause (E);
Btyp : constant Entity_Id := Base_Type (E);
Dim := Expr_Value (Hi) - Expr_Value (Lo) + 1;
- if Dim >= 0 then
+ if Dim > Uint_0 then
Num_Elmts := Num_Elmts * Dim;
else
Num_Elmts := Uint_0;
if Implicit_Packing then
Set_Component_Size (Btyp, Rsiz);
- -- Otherwise give an error message
+ -- Otherwise give an error message, except that if the
+ -- specified Size is zero, there is no need for pragma
+ -- Pack. Note that size zero is not considered
+ -- Addressable.
- else
+ elsif RM_Size (E) /= Uint_0 then
Error_Msg_NE
("size given for& too small", SZ, E);
Error_Msg_N -- CODEFIX
if Sloc (SC) > Sloc (AC) then
Loc := SC;
Error_Msg_NE
- ("?Z?size is not a multiple of alignment for &",
+ ("?.z?size is not a multiple of alignment for &",
Loc, E);
Error_Msg_Sloc := Sloc (AC);
Error_Msg_Uint_1 := Alignment (E);
- Error_Msg_N ("\?Z?alignment of ^ specified #", Loc);
+ Error_Msg_N ("\?.z?alignment of ^ specified #", Loc);
else
Loc := AC;
Error_Msg_NE
- ("?Z?size is not a multiple of alignment for &",
+ ("?.z?size is not a multiple of alignment for &",
Loc, E);
Error_Msg_Sloc := Sloc (SC);
Error_Msg_Uint_1 := RM_Size (E);
- Error_Msg_N ("\?Z?size of ^ specified #", Loc);
+ Error_Msg_N ("\?.z?size of ^ specified #", Loc);
end if;
Error_Msg_Uint_1 := ((RM_Size (E) / Abits) + 1) * Abits;
- Error_Msg_N ("\?Z?Object_Size will be increased to ^", Loc);
+ Error_Msg_N ("\?.z?Object_Size will be increased to ^", Loc);
end if;
end;
end if;
if Is_Type (Full_View (E)) then
Set_Size_Info (E, Full_View (E));
- Set_RM_Size (E, RM_Size (Full_View (E)));
+ Copy_RM_Size (To => E, From => Full_View (E));
end if;
goto Leave;
if Is_Type (E) then
Freeze_And_Append (First_Subtype (E), N, Result);
- -- If we just froze a tagged non-class wide record, then freeze the
+ -- If we just froze a tagged non-class-wide record, then freeze the
-- corresponding class-wide type. This must be done after the tagged
-- type itself is frozen, because the class-wide type refers to the
-- tagged type which generates the class.
and then not Target_Short_Enums
then
- Init_Esize (Typ, Standard_Integer_Size);
+ Set_Esize (Typ, UI_From_Int (Standard_Integer_Size));
Set_Alignment (Typ, Alignment (Standard_Integer));
-- Normal Ada case or size clause present or not Long_C_Enums on target
or else Is_TSS (Id, TSS_Stream_Output)
or else Is_TSS (Id, TSS_Stream_Read)
or else Is_TSS (Id, TSS_Stream_Write)
+ or else Is_TSS (Id, TSS_Put_Image)
or else Nkind (Original_Node (P)) =
N_Subprogram_Renaming_Declaration)
then
Brng : constant Node_Id := Scalar_Range (Btyp);
BLo : constant Node_Id := Low_Bound (Brng);
BHi : constant Node_Id := High_Bound (Brng);
- Par : constant Entity_Id := First_Subtype (Typ);
- Small : constant Ureal := Small_Value (Typ);
+ Ftyp : constant Entity_Id := Underlying_Type (First_Subtype (Typ));
+
+ Small : Ureal;
Loval : Ureal;
Hival : Ureal;
Atype : Entity_Id;
Orig_Hi : Ureal;
-- Save original bounds (for shaving tests)
- Actual_Size : Nat;
+ Actual_Size : Int;
-- Actual size chosen
- function Fsize (Lov, Hiv : Ureal) return Nat;
+ function Fsize (Lov, Hiv : Ureal) return Int;
-- Returns size of type with given bounds. Also leaves these
-- bounds set as the current bounds of the Typ.
-- Fsize --
-----------
- function Fsize (Lov, Hiv : Ureal) return Nat is
+ function Fsize (Lov, Hiv : Ureal) return Int is
begin
Set_Realval (Lo, Lov);
Set_Realval (Hi, Hiv);
function Larger (A, B : Ureal) return Boolean is
begin
- return A > B and then A - Small > B;
+ return A > B and then A - Small_Value (Typ) > B;
end Larger;
-------------
function Smaller (A, B : Ureal) return Boolean is
begin
- return A < B and then A + Small < B;
+ return A < B and then A + Small_Value (Typ) < B;
end Smaller;
-- Start of processing for Freeze_Fixed_Point_Type
-- so that all characteristics of the type (size, bounds) can be
-- computed and validated in the call to Minimum_Size that follows.
- if Has_Delayed_Aspects (First_Subtype (Typ)) then
- Analyze_Aspects_At_Freeze_Point (First_Subtype (Typ));
- Set_Has_Delayed_Aspects (First_Subtype (Typ), False);
+ if Has_Delayed_Aspects (Ftyp) then
+ Analyze_Aspects_At_Freeze_Point (Ftyp);
+ Set_Has_Delayed_Aspects (Ftyp, False);
+ end if;
+
+ -- Inherit the Small value from the first subtype in any case
+
+ if Typ /= Ftyp then
+ Set_Small_Value (Typ, Small_Value (Ftyp));
end if;
-- If Esize of a subtype has not previously been set, set it now
- if Unknown_Esize (Typ) then
+ if not Known_Esize (Typ) then
Atype := Ancestor_Subtype (Typ);
if Present (Atype) then
Set_Esize (Typ, Esize (Atype));
else
- Set_Esize (Typ, Esize (Btyp));
+ Copy_Esize (To => Typ, From => Btyp);
end if;
end if;
- -- The 'small attribute may have been specified with an aspect,
- -- in which case it is processed after a subtype declaration, so
- -- inherit now the specified value.
-
- if Typ /= Par
- and then Present (Find_Aspect (Par, Aspect_Small))
- then
- Set_Small_Value (Typ, Small_Value (Par));
- end if;
-
-- Immediate return if the range is already analyzed. This means that
-- the range is already set, and does not need to be computed by this
-- routine.
return;
end if;
+ Small := Small_Value (Typ);
Loval := Realval (Lo);
Hival := Realval (Hi);
Loval_Excl_EP : Ureal;
Hival_Excl_EP : Ureal;
- Size_Incl_EP : Nat;
- Size_Excl_EP : Nat;
+ Size_Incl_EP : Int;
+ Size_Excl_EP : Int;
Model_Num : Ureal;
- First_Subt : Entity_Id;
Actual_Lo : Ureal;
Actual_Hi : Ureal;
-- to get a base type whose size is smaller than the specified
-- size of the first subtype.
- First_Subt := First_Subtype (Typ);
-
- if Has_Size_Clause (First_Subt)
- and then Size_Incl_EP <= Esize (First_Subt)
+ if Has_Size_Clause (Ftyp)
+ and then Size_Incl_EP <= Esize (Ftyp)
then
Actual_Size := Size_Incl_EP;
Actual_Lo := Loval_Incl_EP;
Actual_Size := 128;
end if;
- Init_Esize (Typ, Actual_Size);
+ Set_Esize (Typ, UI_From_Int (Actual_Size));
Adjust_Esize_For_Alignment (Typ);
end if;
-- Set Esize to calculated size if not set already
- if Unknown_Esize (Typ) then
- Init_Esize (Typ, Actual_Size);
+ if not Known_Esize (Typ) then
+ Set_Esize (Typ, UI_From_Int (Actual_Size));
end if;
-- Set RM_Size if not already set. If already set, check value
Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ));
begin
- if RM_Size (Typ) /= Uint_0 then
+ if Known_RM_Size (Typ) then
if RM_Size (Typ) < Minsiz then
Error_Msg_Uint_1 := RM_Size (Typ);
Error_Msg_Uint_2 := Minsiz;
-- Warn_Overlay --
------------------
- procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Entity_Id) is
+ procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id) is
Ent : constant Entity_Id := Entity (Nam);
-- The object to which the address clause applies
git://gcc.gnu.org / gcc.git / blobdiff