-- present. If errors are found, error messages are posted, and the
-- Real_Range_Specification of Def is reset to Empty.
+ procedure Propagate_Default_Init_Cond_Attributes
+ (From_Typ : Entity_Id;
+ To_Typ : Entity_Id;
+ Parent_To_Derivation : Boolean := False;
+ Private_To_Full_View : Boolean := False);
+ -- Subsidiary to routines Build_Derived_Type and Process_Full_View. Inherit
+ -- all attributes related to pragma Default_Initial_Condition from From_Typ
+ -- to To_Typ. Flag Parent_To_Derivation should be set when the context is
+ -- the creation of a derived type. Flag Private_To_Full_View should be set
+ -- when processing both views of a private type.
+
procedure Record_Type_Declaration
(T : Entity_Id;
N : Node_Id;
end if;
Check_Function_Writable_Actuals (N);
-
- -- Propagate the attributes related to pragma Default_Initial_Condition
- -- from the parent type to the private extension. A derived type always
- -- inherits the default initial condition flag from the parent type. If
- -- the derived type carries its own Default_Initial_Condition pragma,
- -- the flag is later reset in Analyze_Pragma. Note that both flags are
- -- mutually exclusive.
-
- if Has_Inherited_Default_Init_Cond (Parent_Type)
- or else Present (Get_Pragma
- (Parent_Type, Pragma_Default_Initial_Condition))
- then
- Set_Has_Inherited_Default_Init_Cond (Derived_Type);
-
- elsif Has_Default_Init_Cond (Parent_Type) then
- Set_Has_Default_Init_Cond (Derived_Type);
- end if;
end Build_Derived_Record_Type;
------------------------
Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
end if;
+ -- Propagate the attributes related to pragma Default_Initial_Condition
+ -- from the parent type to the private extension. A derived type always
+ -- inherits the default initial condition flag from the parent type. If
+ -- the derived type carries its own Default_Initial_Condition pragma,
+ -- the flag is later reset in Analyze_Pragma. Note that both flags are
+ -- mutually exclusive.
+
+ Propagate_Default_Init_Cond_Attributes
+ (From_Typ => Parent_Type,
+ To_Typ => Derived_Type,
+ Parent_To_Derivation => True);
+
-- If the parent type has delayed rep aspects, then mark the derived
-- type as possibly inheriting a delayed rep aspect.
end if;
end Check_Aliased_Component_Types;
- ----------------------
- -- Check_Completion --
- ----------------------
+ ---------------------------------------
+ -- Check_Anonymous_Access_Components --
+ ---------------------------------------
- procedure Check_Completion (Body_Id : Node_Id := Empty) is
- E : Entity_Id;
+ procedure Check_Anonymous_Access_Components
+ (Typ_Decl : Node_Id;
+ Typ : Entity_Id;
+ Prev : Entity_Id;
+ Comp_List : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Typ_Decl);
+ Anon_Access : Entity_Id;
+ Acc_Def : Node_Id;
+ Comp : Node_Id;
+ Comp_Def : Node_Id;
+ Decl : Node_Id;
+ Type_Def : Node_Id;
- procedure Post_Error;
- -- Post error message for lack of completion for entity E
+ procedure Build_Incomplete_Type_Declaration;
+ -- If the record type contains components that include an access to the
+ -- current record, then create an incomplete type declaration for the
+ -- record, to be used as the designated type of the anonymous access.
+ -- This is done only once, and only if there is no previous partial
+ -- view of the type.
- ----------------
- -- Post_Error --
- ----------------
+ function Designates_T (Subt : Node_Id) return Boolean;
+ -- Check whether a node designates the enclosing record type, or 'Class
+ -- of that type
- procedure Post_Error is
+ function Mentions_T (Acc_Def : Node_Id) return Boolean;
+ -- Check whether an access definition includes a reference to
+ -- the enclosing record type. The reference can be a subtype mark
+ -- in the access definition itself, a 'Class attribute reference, or
+ -- recursively a reference appearing in a parameter specification
+ -- or result definition of an access_to_subprogram definition.
- procedure Missing_Body;
- -- Output missing body message
+ --------------------------------------
+ -- Build_Incomplete_Type_Declaration --
+ --------------------------------------
- ------------------
- -- Missing_Body --
- ------------------
+ procedure Build_Incomplete_Type_Declaration is
+ Decl : Node_Id;
+ Inc_T : Entity_Id;
+ H : Entity_Id;
- procedure Missing_Body is
- begin
- -- Spec is in same unit, so we can post on spec
+ -- Is_Tagged indicates whether the type is tagged. It is tagged if
+ -- it's "is new ... with record" or else "is tagged record ...".
- if In_Same_Source_Unit (Body_Id, E) then
- Error_Msg_N ("missing body for &", E);
+ Is_Tagged : constant Boolean :=
+ (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
+ and then
+ Present (Record_Extension_Part (Type_Definition (Typ_Decl))))
+ or else
+ (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition
+ and then Tagged_Present (Type_Definition (Typ_Decl)));
- -- Spec is in a separate unit, so we have to post on the body
+ begin
+ -- If there is a previous partial view, no need to create a new one
+ -- If the partial view, given by Prev, is incomplete, If Prev is
+ -- a private declaration, full declaration is flagged accordingly.
- else
- Error_Msg_NE ("missing body for & declared#!", Body_Id, E);
+ if Prev /= Typ then
+ if Is_Tagged then
+ Make_Class_Wide_Type (Prev);
+ Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev));
+ Set_Etype (Class_Wide_Type (Typ), Typ);
end if;
- end Missing_Body;
- -- Start of processing for Post_Error
+ return;
- begin
- if not Comes_From_Source (E) then
+ elsif Has_Private_Declaration (Typ) then
- if Ekind_In (E, E_Task_Type, E_Protected_Type) then
- -- It may be an anonymous protected type created for a
- -- single variable. Post error on variable, if present.
+ -- If we refer to T'Class inside T, and T is the completion of a
+ -- private type, then make sure the class-wide type exists.
- declare
- Var : Entity_Id;
+ if Is_Tagged then
+ Make_Class_Wide_Type (Typ);
+ end if;
- begin
- Var := First_Entity (Current_Scope);
- while Present (Var) loop
- exit when Etype (Var) = E
- and then Comes_From_Source (Var);
+ return;
- Next_Entity (Var);
- end loop;
+ -- If there was a previous anonymous access type, the incomplete
+ -- type declaration will have been created already.
- if Present (Var) then
- E := Var;
- end if;
- end;
+ elsif Present (Current_Entity (Typ))
+ and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
+ and then Full_View (Current_Entity (Typ)) = Typ
+ then
+ if Is_Tagged
+ and then Comes_From_Source (Current_Entity (Typ))
+ and then not Is_Tagged_Type (Current_Entity (Typ))
+ then
+ Make_Class_Wide_Type (Typ);
+ Error_Msg_N
+ ("incomplete view of tagged type should be declared tagged??",
+ Parent (Current_Entity (Typ)));
end if;
- end if;
-
- -- If a generated entity has no completion, then either previous
- -- semantic errors have disabled the expansion phase, or else we had
- -- missing subunits, or else we are compiling without expansion,
- -- or else something is very wrong.
-
- if not Comes_From_Source (E) then
- pragma Assert
- (Serious_Errors_Detected > 0
- or else Configurable_Run_Time_Violations > 0
- or else Subunits_Missing
- or else not Expander_Active);
return;
- -- Here for source entity
-
else
- -- Here if no body to post the error message, so we post the error
- -- on the declaration that has no completion. This is not really
- -- the right place to post it, think about this later ???
+ Inc_T := Make_Defining_Identifier (Loc, Chars (Typ));
+ Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T);
- if No (Body_Id) then
- if Is_Type (E) then
- Error_Msg_NE
- ("missing full declaration for }", Parent (E), E);
- else
- Error_Msg_NE ("missing body for &", Parent (E), E);
- end if;
+ -- Type has already been inserted into the current scope. Remove
+ -- it, and add incomplete declaration for type, so that subsequent
+ -- anonymous access types can use it. The entity is unchained from
+ -- the homonym list and from immediate visibility. After analysis,
+ -- the entity in the incomplete declaration becomes immediately
+ -- visible in the record declaration that follows.
- -- Package body has no completion for a declaration that appears
- -- in the corresponding spec. Post error on the body, with a
- -- reference to the non-completed declaration.
+ H := Current_Entity (Typ);
+ if H = Typ then
+ Set_Name_Entity_Id (Chars (Typ), Homonym (Typ));
else
- Error_Msg_Sloc := Sloc (E);
-
- if Is_Type (E) then
- Error_Msg_NE ("missing full declaration for }!", Body_Id, E);
+ while Present (H)
+ and then Homonym (H) /= Typ
+ loop
+ H := Homonym (Typ);
+ end loop;
- elsif Is_Overloadable (E)
- and then Current_Entity_In_Scope (E) /= E
- then
- -- It may be that the completion is mistyped and appears as
- -- a distinct overloading of the entity.
+ Set_Homonym (H, Homonym (Typ));
+ end if;
- declare
- Candidate : constant Entity_Id :=
- Current_Entity_In_Scope (E);
- Decl : constant Node_Id :=
- Unit_Declaration_Node (Candidate);
+ Insert_Before (Typ_Decl, Decl);
+ Analyze (Decl);
+ Set_Full_View (Inc_T, Typ);
- begin
- if Is_Overloadable (Candidate)
- and then Ekind (Candidate) = Ekind (E)
- and then Nkind (Decl) = N_Subprogram_Body
- and then Acts_As_Spec (Decl)
- then
- Check_Type_Conformant (Candidate, E);
+ if Is_Tagged then
- else
- Missing_Body;
- end if;
- end;
+ -- Create a common class-wide type for both views, and set the
+ -- Etype of the class-wide type to the full view.
- else
- Missing_Body;
- end if;
+ Make_Class_Wide_Type (Inc_T);
+ Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T));
+ Set_Etype (Class_Wide_Type (Typ), Typ);
end if;
end if;
- end Post_Error;
-
- -- Start of processing for Check_Completion
+ end Build_Incomplete_Type_Declaration;
- begin
- E := First_Entity (Current_Scope);
- while Present (E) loop
- if Is_Intrinsic_Subprogram (E) then
- null;
+ ------------------
+ -- Designates_T --
+ ------------------
- -- The following situation requires special handling: a child unit
- -- that appears in the context clause of the body of its parent:
+ function Designates_T (Subt : Node_Id) return Boolean is
+ Type_Id : constant Name_Id := Chars (Typ);
- -- procedure Parent.Child (...);
+ function Names_T (Nam : Node_Id) return Boolean;
+ -- The record type has not been introduced in the current scope
+ -- yet, so we must examine the name of the type itself, either
+ -- an identifier T, or an expanded name of the form P.T, where
+ -- P denotes the current scope.
- -- with Parent.Child;
- -- package body Parent is
+ -------------
+ -- Names_T --
+ -------------
- -- Here Parent.Child appears as a local entity, but should not be
- -- flagged as requiring completion, because it is a compilation
- -- unit.
+ function Names_T (Nam : Node_Id) return Boolean is
+ begin
+ if Nkind (Nam) = N_Identifier then
+ return Chars (Nam) = Type_Id;
- -- Ignore missing completion for a subprogram that does not come from
- -- source (including the _Call primitive operation of RAS types,
- -- which has to have the flag Comes_From_Source for other purposes):
- -- we assume that the expander will provide the missing completion.
- -- In case of previous errors, other expansion actions that provide
- -- bodies for null procedures with not be invoked, so inhibit message
- -- in those cases.
-
- -- Note that E_Operator is not in the list that follows, because
- -- this kind is reserved for predefined operators, that are
- -- intrinsic and do not need completion.
-
- elsif Ekind (E) = E_Function
- or else Ekind (E) = E_Procedure
- or else Ekind (E) = E_Generic_Function
- or else Ekind (E) = E_Generic_Procedure
- then
- if Has_Completion (E) then
- null;
-
- elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
- null;
-
- elsif Is_Subprogram (E)
- and then (not Comes_From_Source (E)
- or else Chars (E) = Name_uCall)
- then
- null;
-
- elsif
- Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
- then
- null;
-
- elsif Nkind (Parent (E)) = N_Procedure_Specification
- and then Null_Present (Parent (E))
- and then Serious_Errors_Detected > 0
- then
- null;
-
- else
- Post_Error;
- end if;
+ elsif Nkind (Nam) = N_Selected_Component then
+ if Chars (Selector_Name (Nam)) = Type_Id then
+ if Nkind (Prefix (Nam)) = N_Identifier then
+ return Chars (Prefix (Nam)) = Chars (Current_Scope);
- elsif Is_Entry (E) then
- if not Has_Completion (E) and then
- (Ekind (Scope (E)) = E_Protected_Object
- or else Ekind (Scope (E)) = E_Protected_Type)
- then
- Post_Error;
- end if;
+ elsif Nkind (Prefix (Nam)) = N_Selected_Component then
+ return Chars (Selector_Name (Prefix (Nam))) =
+ Chars (Current_Scope);
+ else
+ return False;
+ end if;
- elsif Is_Package_Or_Generic_Package (E) then
- if Unit_Requires_Body (E) then
- if not Has_Completion (E)
- and then Nkind (Parent (Unit_Declaration_Node (E))) /=
- N_Compilation_Unit
- then
- Post_Error;
+ else
+ return False;
end if;
- elsif not Is_Child_Unit (E) then
- May_Need_Implicit_Body (E);
+ else
+ return False;
end if;
+ end Names_T;
- -- A formal incomplete type (Ada 2012) does not require a completion;
- -- other incomplete type declarations do.
-
- elsif Ekind (E) = E_Incomplete_Type
- and then No (Underlying_Type (E))
- and then not Is_Generic_Type (E)
- then
- Post_Error;
+ -- Start of processing for Designates_T
- elsif (Ekind (E) = E_Task_Type or else
- Ekind (E) = E_Protected_Type)
- and then not Has_Completion (E)
- then
- Post_Error;
+ begin
+ if Nkind (Subt) = N_Identifier then
+ return Chars (Subt) = Type_Id;
- -- A single task declared in the current scope is a constant, verify
- -- that the body of its anonymous type is in the same scope. If the
- -- task is defined elsewhere, this may be a renaming declaration for
- -- which no completion is needed.
+ -- Reference can be through an expanded name which has not been
+ -- analyzed yet, and which designates enclosing scopes.
- elsif Ekind (E) = E_Constant
- and then Ekind (Etype (E)) = E_Task_Type
- and then not Has_Completion (Etype (E))
- and then Scope (Etype (E)) = Current_Scope
- then
- Post_Error;
+ elsif Nkind (Subt) = N_Selected_Component then
+ if Names_T (Subt) then
+ return True;
- elsif Ekind (E) = E_Protected_Object
- and then not Has_Completion (Etype (E))
- then
- Post_Error;
+ -- Otherwise it must denote an entity that is already visible.
+ -- The access definition may name a subtype of the enclosing
+ -- type, if there is a previous incomplete declaration for it.
- elsif Ekind (E) = E_Record_Type then
- if Is_Tagged_Type (E) then
- Check_Abstract_Overriding (E);
- Check_Conventions (E);
+ else
+ Find_Selected_Component (Subt);
+ return
+ Is_Entity_Name (Subt)
+ and then Scope (Entity (Subt)) = Current_Scope
+ and then
+ (Chars (Base_Type (Entity (Subt))) = Type_Id
+ or else
+ (Is_Class_Wide_Type (Entity (Subt))
+ and then
+ Chars (Etype (Base_Type (Entity (Subt)))) =
+ Type_Id));
end if;
- Check_Aliased_Component_Types (E);
+ -- A reference to the current type may appear as the prefix of
+ -- a 'Class attribute.
- elsif Ekind (E) = E_Array_Type then
- Check_Aliased_Component_Types (E);
+ elsif Nkind (Subt) = N_Attribute_Reference
+ and then Attribute_Name (Subt) = Name_Class
+ then
+ return Names_T (Prefix (Subt));
+ else
+ return False;
end if;
+ end Designates_T;
- Next_Entity (E);
- end loop;
- end Check_Completion;
+ ----------------
+ -- Mentions_T --
+ ----------------
- ------------------------------------
- -- Check_CPP_Type_Has_No_Defaults --
- ------------------------------------
+ function Mentions_T (Acc_Def : Node_Id) return Boolean is
+ Param_Spec : Node_Id;
- procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is
- Tdef : constant Node_Id := Type_Definition (Declaration_Node (T));
- Clist : Node_Id;
- Comp : Node_Id;
+ Acc_Subprg : constant Node_Id :=
+ Access_To_Subprogram_Definition (Acc_Def);
- begin
- -- Obtain the component list
+ begin
+ if No (Acc_Subprg) then
+ return Designates_T (Subtype_Mark (Acc_Def));
+ end if;
- if Nkind (Tdef) = N_Record_Definition then
- Clist := Component_List (Tdef);
- else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
- Clist := Component_List (Record_Extension_Part (Tdef));
- end if;
+ -- Component is an access_to_subprogram: examine its formals,
+ -- and result definition in the case of an access_to_function.
- -- Check all components to ensure no default expressions
+ Param_Spec := First (Parameter_Specifications (Acc_Subprg));
+ while Present (Param_Spec) loop
+ if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition
+ and then Mentions_T (Parameter_Type (Param_Spec))
+ then
+ return True;
- if Present (Clist) then
- Comp := First (Component_Items (Clist));
- while Present (Comp) loop
- if Present (Expression (Comp)) then
- Error_Msg_N
- ("component of imported 'C'P'P type cannot have "
- & "default expression", Expression (Comp));
+ elsif Designates_T (Parameter_Type (Param_Spec)) then
+ return True;
end if;
- Next (Comp);
+ Next (Param_Spec);
end loop;
- end if;
- end Check_CPP_Type_Has_No_Defaults;
-
- ----------------------------
- -- Check_Delta_Expression --
- ----------------------------
- procedure Check_Delta_Expression (E : Node_Id) is
- begin
- if not (Is_Real_Type (Etype (E))) then
- Wrong_Type (E, Any_Real);
+ if Nkind (Acc_Subprg) = N_Access_Function_Definition then
+ if Nkind (Result_Definition (Acc_Subprg)) =
+ N_Access_Definition
+ then
+ return Mentions_T (Result_Definition (Acc_Subprg));
+ else
+ return Designates_T (Result_Definition (Acc_Subprg));
+ end if;
+ end if;
- elsif not Is_OK_Static_Expression (E) then
- Flag_Non_Static_Expr
- ("non-static expression used for delta value!", E);
+ return False;
+ end Mentions_T;
- elsif not UR_Is_Positive (Expr_Value_R (E)) then
- Error_Msg_N ("delta expression must be positive", E);
+ -- Start of processing for Check_Anonymous_Access_Components
- else
+ begin
+ if No (Comp_List) then
return;
end if;
- -- If any of above errors occurred, then replace the incorrect
- -- expression by the real 0.1, which should prevent further errors.
-
- Rewrite (E,
- Make_Real_Literal (Sloc (E), Ureal_Tenth));
- Analyze_And_Resolve (E, Standard_Float);
- end Check_Delta_Expression;
+ Comp := First (Component_Items (Comp_List));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Declaration
+ and then Present
+ (Access_Definition (Component_Definition (Comp)))
+ and then
+ Mentions_T (Access_Definition (Component_Definition (Comp)))
+ then
+ Comp_Def := Component_Definition (Comp);
+ Acc_Def :=
+ Access_To_Subprogram_Definition (Access_Definition (Comp_Def));
- -----------------------------
- -- Check_Digits_Expression --
- -----------------------------
+ Build_Incomplete_Type_Declaration;
+ Anon_Access := Make_Temporary (Loc, 'S');
- procedure Check_Digits_Expression (E : Node_Id) is
- begin
- if not (Is_Integer_Type (Etype (E))) then
- Wrong_Type (E, Any_Integer);
+ -- Create a declaration for the anonymous access type: either
+ -- an access_to_object or an access_to_subprogram.
- elsif not Is_OK_Static_Expression (E) then
- Flag_Non_Static_Expr
- ("non-static expression used for digits value!", E);
+ if Present (Acc_Def) then
+ if Nkind (Acc_Def) = N_Access_Function_Definition then
+ Type_Def :=
+ Make_Access_Function_Definition (Loc,
+ Parameter_Specifications =>
+ Parameter_Specifications (Acc_Def),
+ Result_Definition => Result_Definition (Acc_Def));
+ else
+ Type_Def :=
+ Make_Access_Procedure_Definition (Loc,
+ Parameter_Specifications =>
+ Parameter_Specifications (Acc_Def));
+ end if;
- elsif Expr_Value (E) <= 0 then
- Error_Msg_N ("digits value must be greater than zero", E);
+ else
+ Type_Def :=
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ Relocate_Node
+ (Subtype_Mark (Access_Definition (Comp_Def))));
- else
- return;
- end if;
+ Set_Constant_Present
+ (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
+ Set_All_Present
+ (Type_Def, All_Present (Access_Definition (Comp_Def)));
+ end if;
- -- If any of above errors occurred, then replace the incorrect
- -- expression by the integer 1, which should prevent further errors.
+ Set_Null_Exclusion_Present
+ (Type_Def,
+ Null_Exclusion_Present (Access_Definition (Comp_Def)));
- Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
- Analyze_And_Resolve (E, Standard_Integer);
+ Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Anon_Access,
+ Type_Definition => Type_Def);
- end Check_Digits_Expression;
+ Insert_Before (Typ_Decl, Decl);
+ Analyze (Decl);
- --------------------------
- -- Check_Initialization --
- --------------------------
+ -- If an access to subprogram, create the extra formals
- procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
- begin
- -- Special processing for limited types
+ if Present (Acc_Def) then
+ Create_Extra_Formals (Designated_Type (Anon_Access));
- if Is_Limited_Type (T)
- and then not In_Instance
- and then not In_Inlined_Body
- then
- if not OK_For_Limited_Init (T, Exp) then
+ -- If an access to object, preserve entity of designated type,
+ -- for ASIS use, before rewriting the component definition.
- -- In GNAT mode, this is just a warning, to allow it to be evilly
- -- turned off. Otherwise it is a real error.
+ else
+ declare
+ Desig : Entity_Id;
- if GNAT_Mode then
- Error_Msg_N
- ("??cannot initialize entities of limited type!", Exp);
+ begin
+ Desig := Entity (Subtype_Indication (Type_Def));
- elsif Ada_Version < Ada_2005 then
+ -- If the access definition is to the current record,
+ -- the visible entity at this point is an incomplete
+ -- type. Retrieve the full view to simplify ASIS queries
- -- The side effect removal machinery may generate illegal Ada
- -- code to avoid the usage of access types and 'reference in
- -- SPARK mode. Since this is legal code with respect to theorem
- -- proving, do not emit the error.
+ if Ekind (Desig) = E_Incomplete_Type then
+ Desig := Full_View (Desig);
+ end if;
- if GNATprove_Mode
- and then Nkind (Exp) = N_Function_Call
- and then Nkind (Parent (Exp)) = N_Object_Declaration
- and then not Comes_From_Source
- (Defining_Identifier (Parent (Exp)))
- then
- null;
+ Set_Entity
+ (Subtype_Mark (Access_Definition (Comp_Def)), Desig);
+ end;
+ end if;
- else
- Error_Msg_N
- ("cannot initialize entities of limited type", Exp);
- Explain_Limited_Type (T, Exp);
- end if;
+ Rewrite (Comp_Def,
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Anon_Access, Loc)));
+ if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
+ Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
else
- -- Specialize error message according to kind of illegal
- -- initial expression.
-
- if Nkind (Exp) = N_Type_Conversion
- and then Nkind (Expression (Exp)) = N_Function_Call
- then
- Error_Msg_N
- ("illegal context for call"
- & " to function with limited result", Exp);
-
- else
- Error_Msg_N
- ("initialization of limited object requires aggregate "
- & "or function call", Exp);
- end if;
+ Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
end if;
+
+ Set_Is_Local_Anonymous_Access (Anon_Access);
end if;
- end if;
- -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets
- -- set unless we can be sure that no range check is required.
+ Next (Comp);
+ end loop;
- if (GNATprove_Mode or not Expander_Active)
- and then Is_Scalar_Type (T)
- and then not Is_In_Range (Exp, T, Assume_Valid => True)
- then
- Set_Do_Range_Check (Exp);
+ if Present (Variant_Part (Comp_List)) then
+ declare
+ V : Node_Id;
+ begin
+ V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
+ while Present (V) loop
+ Check_Anonymous_Access_Components
+ (Typ_Decl, Typ, Prev, Component_List (V));
+ Next_Non_Pragma (V);
+ end loop;
+ end;
end if;
- end Check_Initialization;
+ end Check_Anonymous_Access_Components;
----------------------
- -- Check_Interfaces --
+ -- Check_Completion --
----------------------
- procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is
- Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N));
+ procedure Check_Completion (Body_Id : Node_Id := Empty) is
+ E : Entity_Id;
- Iface : Node_Id;
- Iface_Def : Node_Id;
- Iface_Typ : Entity_Id;
- Parent_Node : Node_Id;
+ procedure Post_Error;
+ -- Post error message for lack of completion for entity E
- Is_Task : Boolean := False;
- -- Set True if parent type or any progenitor is a task interface
+ ----------------
+ -- Post_Error --
+ ----------------
- Is_Protected : Boolean := False;
- -- Set True if parent type or any progenitor is a protected interface
+ procedure Post_Error is
- procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
- -- Check that a progenitor is compatible with declaration.
- -- Error is posted on Error_Node.
+ procedure Missing_Body;
+ -- Output missing body message
- ------------------
- -- Check_Ifaces --
- ------------------
+ ------------------
+ -- Missing_Body --
+ ------------------
- procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
- Iface_Id : constant Entity_Id :=
- Defining_Identifier (Parent (Iface_Def));
- Type_Def : Node_Id;
+ procedure Missing_Body is
+ begin
+ -- Spec is in same unit, so we can post on spec
- begin
- if Nkind (N) = N_Private_Extension_Declaration then
- Type_Def := N;
- else
- Type_Def := Type_Definition (N);
- end if;
+ if In_Same_Source_Unit (Body_Id, E) then
+ Error_Msg_N ("missing body for &", E);
- if Is_Task_Interface (Iface_Id) then
- Is_Task := True;
+ -- Spec is in a separate unit, so we have to post on the body
- elsif Is_Protected_Interface (Iface_Id) then
- Is_Protected := True;
- end if;
+ else
+ Error_Msg_NE ("missing body for & declared#!", Body_Id, E);
+ end if;
+ end Missing_Body;
- if Is_Synchronized_Interface (Iface_Id) then
+ -- Start of processing for Post_Error
- -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
- -- extension derived from a synchronized interface must explicitly
- -- be declared synchronized, because the full view will be a
- -- synchronized type.
+ begin
+ if not Comes_From_Source (E) then
- if Nkind (N) = N_Private_Extension_Declaration then
- if not Synchronized_Present (N) then
- Error_Msg_NE
- ("private extension of& must be explicitly synchronized",
- N, Iface_Id);
- end if;
+ if Ekind_In (E, E_Task_Type, E_Protected_Type) then
- -- However, by 3.9.4(16/2), a full type that is a record extension
- -- is never allowed to derive from a synchronized interface (note
- -- that interfaces must be excluded from this check, because those
- -- are represented by derived type definitions in some cases).
+ -- It may be an anonymous protected type created for a
+ -- single variable. Post error on variable, if present.
- elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition
- and then not Interface_Present (Type_Definition (N))
- then
- Error_Msg_N ("record extension cannot derive from synchronized"
- & " interface", Error_Node);
- end if;
- end if;
+ declare
+ Var : Entity_Id;
- -- Check that the characteristics of the progenitor are compatible
- -- with the explicit qualifier in the declaration.
- -- The check only applies to qualifiers that come from source.
- -- Limited_Present also appears in the declaration of corresponding
- -- records, and the check does not apply to them.
+ begin
+ Var := First_Entity (Current_Scope);
+ while Present (Var) loop
+ exit when Etype (Var) = E
+ and then Comes_From_Source (Var);
- if Limited_Present (Type_Def)
- and then not
- Is_Concurrent_Record_Type (Defining_Identifier (N))
- then
- if Is_Limited_Interface (Parent_Type)
- and then not Is_Limited_Interface (Iface_Id)
- then
- Error_Msg_NE
- ("progenitor& must be limited interface",
- Error_Node, Iface_Id);
+ Next_Entity (Var);
+ end loop;
- elsif
- (Task_Present (Iface_Def)
- or else Protected_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def))
- and then Nkind (N) /= N_Private_Extension_Declaration
- and then not Error_Posted (N)
- then
- Error_Msg_NE
- ("progenitor& must be limited interface",
- Error_Node, Iface_Id);
+ if Present (Var) then
+ E := Var;
+ end if;
+ end;
end if;
+ end if;
- -- Protected interfaces can only inherit from limited, synchronized
- -- or protected interfaces.
+ -- If a generated entity has no completion, then either previous
+ -- semantic errors have disabled the expansion phase, or else we had
+ -- missing subunits, or else we are compiling without expansion,
+ -- or else something is very wrong.
- elsif Nkind (N) = N_Full_Type_Declaration
- and then Protected_Present (Type_Def)
- then
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- or else Protected_Present (Iface_Def)
- then
- null;
+ if not Comes_From_Source (E) then
+ pragma Assert
+ (Serious_Errors_Detected > 0
+ or else Configurable_Run_Time_Violations > 0
+ or else Subunits_Missing
+ or else not Expander_Active);
+ return;
- elsif Task_Present (Iface_Def) then
- Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
- & " from task interface", Error_Node);
+ -- Here for source entity
- else
- Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
- & " from non-limited interface", Error_Node);
- end if;
+ else
+ -- Here if no body to post the error message, so we post the error
+ -- on the declaration that has no completion. This is not really
+ -- the right place to post it, think about this later ???
- -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from
- -- limited and synchronized.
+ if No (Body_Id) then
+ if Is_Type (E) then
+ Error_Msg_NE
+ ("missing full declaration for }", Parent (E), E);
+ else
+ Error_Msg_NE ("missing body for &", Parent (E), E);
+ end if;
- elsif Synchronized_Present (Type_Def) then
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- then
- null;
+ -- Package body has no completion for a declaration that appears
+ -- in the corresponding spec. Post error on the body, with a
+ -- reference to the non-completed declaration.
- elsif Protected_Present (Iface_Def)
- and then Nkind (N) /= N_Private_Extension_Declaration
- then
- Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
- & " from protected interface", Error_Node);
+ else
+ Error_Msg_Sloc := Sloc (E);
- elsif Task_Present (Iface_Def)
- and then Nkind (N) /= N_Private_Extension_Declaration
- then
- Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
- & " from task interface", Error_Node);
+ if Is_Type (E) then
+ Error_Msg_NE ("missing full declaration for }!", Body_Id, E);
- elsif not Is_Limited_Interface (Iface_Id) then
- Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
- & " from non-limited interface", Error_Node);
- end if;
+ elsif Is_Overloadable (E)
+ and then Current_Entity_In_Scope (E) /= E
+ then
+ -- It may be that the completion is mistyped and appears as
+ -- a distinct overloading of the entity.
- -- Ada 2005 (AI-345): Task interfaces can only inherit from limited,
- -- synchronized or task interfaces.
+ declare
+ Candidate : constant Entity_Id :=
+ Current_Entity_In_Scope (E);
+ Decl : constant Node_Id :=
+ Unit_Declaration_Node (Candidate);
- elsif Nkind (N) = N_Full_Type_Declaration
- and then Task_Present (Type_Def)
- then
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- or else Task_Present (Iface_Def)
- then
- null;
+ begin
+ if Is_Overloadable (Candidate)
+ and then Ekind (Candidate) = Ekind (E)
+ and then Nkind (Decl) = N_Subprogram_Body
+ and then Acts_As_Spec (Decl)
+ then
+ Check_Type_Conformant (Candidate, E);
- elsif Protected_Present (Iface_Def) then
- Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
- & " protected interface", Error_Node);
+ else
+ Missing_Body;
+ end if;
+ end;
- else
- Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
- & " non-limited interface", Error_Node);
+ else
+ Missing_Body;
+ end if;
end if;
end if;
- end Check_Ifaces;
+ end Post_Error;
- -- Start of processing for Check_Interfaces
+ -- Start of processing for Check_Completion
begin
- if Is_Interface (Parent_Type) then
- if Is_Task_Interface (Parent_Type) then
- Is_Task := True;
+ E := First_Entity (Current_Scope);
+ while Present (E) loop
+ if Is_Intrinsic_Subprogram (E) then
+ null;
- elsif Is_Protected_Interface (Parent_Type) then
- Is_Protected := True;
- end if;
- end if;
+ -- The following situation requires special handling: a child unit
+ -- that appears in the context clause of the body of its parent:
- if Nkind (N) = N_Private_Extension_Declaration then
+ -- procedure Parent.Child (...);
- -- Check that progenitors are compatible with declaration
+ -- with Parent.Child;
+ -- package body Parent is
- Iface := First (Interface_List (Def));
- while Present (Iface) loop
- Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+ -- Here Parent.Child appears as a local entity, but should not be
+ -- flagged as requiring completion, because it is a compilation
+ -- unit.
- Parent_Node := Parent (Base_Type (Iface_Typ));
- Iface_Def := Type_Definition (Parent_Node);
+ -- Ignore missing completion for a subprogram that does not come from
+ -- source (including the _Call primitive operation of RAS types,
+ -- which has to have the flag Comes_From_Source for other purposes):
+ -- we assume that the expander will provide the missing completion.
+ -- In case of previous errors, other expansion actions that provide
+ -- bodies for null procedures with not be invoked, so inhibit message
+ -- in those cases.
- if not Is_Interface (Iface_Typ) then
- Diagnose_Interface (Iface, Iface_Typ);
+ -- Note that E_Operator is not in the list that follows, because
+ -- this kind is reserved for predefined operators, that are
+ -- intrinsic and do not need completion.
+
+ elsif Ekind_In (E, E_Function,
+ E_Procedure,
+ E_Generic_Function,
+ E_Generic_Procedure)
+ then
+ if Has_Completion (E) then
+ null;
+
+ elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
+ null;
+
+ elsif Is_Subprogram (E)
+ and then (not Comes_From_Source (E)
+ or else Chars (E) = Name_uCall)
+ then
+ null;
+
+ elsif
+ Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
+ then
+ null;
+
+ elsif Nkind (Parent (E)) = N_Procedure_Specification
+ and then Null_Present (Parent (E))
+ and then Serious_Errors_Detected > 0
+ then
+ null;
else
- Check_Ifaces (Iface_Def, Iface);
+ Post_Error;
end if;
- Next (Iface);
- end loop;
+ elsif Is_Entry (E) then
+ if not Has_Completion (E) and then
+ (Ekind (Scope (E)) = E_Protected_Object
+ or else Ekind (Scope (E)) = E_Protected_Type)
+ then
+ Post_Error;
+ end if;
- if Is_Task and Is_Protected then
- Error_Msg_N
- ("type cannot derive from task and protected interface", N);
- end if;
+ elsif Is_Package_Or_Generic_Package (E) then
+ if Unit_Requires_Body (E) then
+ if not Has_Completion (E)
+ and then Nkind (Parent (Unit_Declaration_Node (E))) /=
+ N_Compilation_Unit
+ then
+ Post_Error;
+ end if;
- return;
- end if;
+ elsif not Is_Child_Unit (E) then
+ May_Need_Implicit_Body (E);
+ end if;
- -- Full type declaration of derived type.
- -- Check compatibility with parent if it is interface type
+ -- A formal incomplete type (Ada 2012) does not require a completion;
+ -- other incomplete type declarations do.
- if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
- and then Is_Interface (Parent_Type)
- then
- Parent_Node := Parent (Parent_Type);
+ elsif Ekind (E) = E_Incomplete_Type
+ and then No (Underlying_Type (E))
+ and then not Is_Generic_Type (E)
+ then
+ Post_Error;
- -- More detailed checks for interface varieties
+ elsif Ekind_In (E, E_Task_Type, E_Protected_Type)
+ and then not Has_Completion (E)
+ then
+ Post_Error;
- Check_Ifaces
- (Iface_Def => Type_Definition (Parent_Node),
- Error_Node => Subtype_Indication (Type_Definition (N)));
- end if;
+ -- A single task declared in the current scope is a constant, verify
+ -- that the body of its anonymous type is in the same scope. If the
+ -- task is defined elsewhere, this may be a renaming declaration for
+ -- which no completion is needed.
- Iface := First (Interface_List (Def));
- while Present (Iface) loop
- Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+ elsif Ekind (E) = E_Constant
+ and then Ekind (Etype (E)) = E_Task_Type
+ and then not Has_Completion (Etype (E))
+ and then Scope (Etype (E)) = Current_Scope
+ then
+ Post_Error;
- Parent_Node := Parent (Base_Type (Iface_Typ));
- Iface_Def := Type_Definition (Parent_Node);
+ elsif Ekind (E) = E_Protected_Object
+ and then not Has_Completion (Etype (E))
+ then
+ Post_Error;
- if not Is_Interface (Iface_Typ) then
- Diagnose_Interface (Iface, Iface_Typ);
+ elsif Ekind (E) = E_Record_Type then
+ if Is_Tagged_Type (E) then
+ Check_Abstract_Overriding (E);
+ Check_Conventions (E);
+ end if;
- else
- -- "The declaration of a specific descendant of an interface
- -- type freezes the interface type" RM 13.14
+ Check_Aliased_Component_Types (E);
+
+ elsif Ekind (E) = E_Array_Type then
+ Check_Aliased_Component_Types (E);
- Freeze_Before (N, Iface_Typ);
- Check_Ifaces (Iface_Def, Error_Node => Iface);
end if;
- Next (Iface);
+ Next_Entity (E);
end loop;
-
- if Is_Task and Is_Protected then
- Error_Msg_N
- ("type cannot derive from task and protected interface", N);
- end if;
- end Check_Interfaces;
+ end Check_Completion;
------------------------------------
- -- Check_Or_Process_Discriminants --
+ -- Check_CPP_Type_Has_No_Defaults --
------------------------------------
- -- If an incomplete or private type declaration was already given for the
- -- type, the discriminants may have already been processed if they were
- -- present on the incomplete declaration. In this case a full conformance
- -- check has been performed in Find_Type_Name, and we then recheck here
- -- some properties that can't be checked on the partial view alone.
- -- Otherwise we call Process_Discriminants.
+ procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is
+ Tdef : constant Node_Id := Type_Definition (Declaration_Node (T));
+ Clist : Node_Id;
+ Comp : Node_Id;
- procedure Check_Or_Process_Discriminants
- (N : Node_Id;
- T : Entity_Id;
- Prev : Entity_Id := Empty)
- is
begin
- if Has_Discriminants (T) then
-
- -- Discriminants are already set on T if they were already present
- -- on the partial view. Make them visible to component declarations.
-
- declare
- D : Entity_Id;
- -- Discriminant on T (full view) referencing expr on partial view
-
- Prev_D : Entity_Id;
- -- Entity of corresponding discriminant on partial view
-
- New_D : Node_Id;
- -- Discriminant specification for full view, expression is the
- -- syntactic copy on full view (which has been checked for
- -- conformance with partial view), only used here to post error
- -- message.
-
- begin
- D := First_Discriminant (T);
- New_D := First (Discriminant_Specifications (N));
- while Present (D) loop
- Prev_D := Current_Entity (D);
- Set_Current_Entity (D);
- Set_Is_Immediately_Visible (D);
- Set_Homonym (D, Prev_D);
-
- -- Handle the case where there is an untagged partial view and
- -- the full view is tagged: must disallow discriminants with
- -- defaults, unless compiling for Ada 2012, which allows a
- -- limited tagged type to have defaulted discriminants (see
- -- AI05-0214). However, suppress error here if it was already
- -- reported on the default expression of the partial view.
-
- if Is_Tagged_Type (T)
- and then Present (Expression (Parent (D)))
- and then (not Is_Limited_Type (Current_Scope)
- or else Ada_Version < Ada_2012)
- and then not Error_Posted (Expression (Parent (D)))
- then
- if Ada_Version >= Ada_2012 then
- Error_Msg_N
- ("discriminants of nonlimited tagged type cannot have"
- & " defaults",
- Expression (New_D));
- else
- Error_Msg_N
- ("discriminants of tagged type cannot have defaults",
- Expression (New_D));
- end if;
- end if;
-
- -- Ada 2005 (AI-230): Access discriminant allowed in
- -- non-limited record types.
-
- if Ada_Version < Ada_2005 then
+ -- Obtain the component list
- -- This restriction gets applied to the full type here. It
- -- has already been applied earlier to the partial view.
+ if Nkind (Tdef) = N_Record_Definition then
+ Clist := Component_List (Tdef);
+ else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
+ Clist := Component_List (Record_Extension_Part (Tdef));
+ end if;
- Check_Access_Discriminant_Requires_Limited (Parent (D), N);
- end if;
+ -- Check all components to ensure no default expressions
- Next_Discriminant (D);
- Next (New_D);
- end loop;
- end;
+ if Present (Clist) then
+ Comp := First (Component_Items (Clist));
+ while Present (Comp) loop
+ if Present (Expression (Comp)) then
+ Error_Msg_N
+ ("component of imported 'C'P'P type cannot have "
+ & "default expression", Expression (Comp));
+ end if;
- elsif Present (Discriminant_Specifications (N)) then
- Process_Discriminants (N, Prev);
+ Next (Comp);
+ end loop;
end if;
- end Check_Or_Process_Discriminants;
+ end Check_CPP_Type_Has_No_Defaults;
- ----------------------
- -- Check_Real_Bound --
- ----------------------
+ ----------------------------
+ -- Check_Delta_Expression --
+ ----------------------------
- procedure Check_Real_Bound (Bound : Node_Id) is
+ procedure Check_Delta_Expression (E : Node_Id) is
begin
- if not Is_Real_Type (Etype (Bound)) then
- Error_Msg_N
- ("bound in real type definition must be of real type", Bound);
+ if not (Is_Real_Type (Etype (E))) then
+ Wrong_Type (E, Any_Real);
- elsif not Is_OK_Static_Expression (Bound) then
+ elsif not Is_OK_Static_Expression (E) then
Flag_Non_Static_Expr
- ("non-static expression used for real type bound!", Bound);
+ ("non-static expression used for delta value!", E);
+
+ elsif not UR_Is_Positive (Expr_Value_R (E)) then
+ Error_Msg_N ("delta expression must be positive", E);
else
return;
end if;
- Rewrite
- (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
- Analyze (Bound);
- Resolve (Bound, Standard_Float);
- end Check_Real_Bound;
+ -- If any of above errors occurred, then replace the incorrect
+ -- expression by the real 0.1, which should prevent further errors.
- ------------------------------
- -- Complete_Private_Subtype --
- ------------------------------
+ Rewrite (E,
+ Make_Real_Literal (Sloc (E), Ureal_Tenth));
+ Analyze_And_Resolve (E, Standard_Float);
+ end Check_Delta_Expression;
- procedure Complete_Private_Subtype
- (Priv : Entity_Id;
- Full : Entity_Id;
- Full_Base : Entity_Id;
- Related_Nod : Node_Id)
- is
- Save_Next_Entity : Entity_Id;
- Save_Homonym : Entity_Id;
+ -----------------------------
+ -- Check_Digits_Expression --
+ -----------------------------
+ procedure Check_Digits_Expression (E : Node_Id) is
begin
- -- Set semantic attributes for (implicit) private subtype completion.
- -- If the full type has no discriminants, then it is a copy of the full
- -- view of the base. Otherwise, it is a subtype of the base with a
- -- possible discriminant constraint. Save and restore the original
- -- Next_Entity field of full to ensure that the calls to Copy_Node
- -- do not corrupt the entity chain.
-
- -- Note that the type of the full view is the same entity as the type of
- -- the partial view. In this fashion, the subtype has access to the
- -- correct view of the parent.
-
- Save_Next_Entity := Next_Entity (Full);
- Save_Homonym := Homonym (Priv);
+ if not (Is_Integer_Type (Etype (E))) then
+ Wrong_Type (E, Any_Integer);
- case Ekind (Full_Base) is
- when E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- Private_Kind |
- Task_Kind |
- Protected_Kind =>
- Copy_Node (Priv, Full);
+ elsif not Is_OK_Static_Expression (E) then
+ Flag_Non_Static_Expr
+ ("non-static expression used for digits value!", E);
- Set_Has_Discriminants
- (Full, Has_Discriminants (Full_Base));
- Set_Has_Unknown_Discriminants
- (Full, Has_Unknown_Discriminants (Full_Base));
- Set_First_Entity (Full, First_Entity (Full_Base));
- Set_Last_Entity (Full, Last_Entity (Full_Base));
+ elsif Expr_Value (E) <= 0 then
+ Error_Msg_N ("digits value must be greater than zero", E);
- -- If the underlying base type is constrained, we know that the
- -- full view of the subtype is constrained as well (the converse
- -- is not necessarily true).
+ else
+ return;
+ end if;
- if Is_Constrained (Full_Base) then
- Set_Is_Constrained (Full);
- end if;
+ -- If any of above errors occurred, then replace the incorrect
+ -- expression by the integer 1, which should prevent further errors.
- when others =>
- Copy_Node (Full_Base, Full);
+ Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
+ Analyze_And_Resolve (E, Standard_Integer);
- Set_Chars (Full, Chars (Priv));
- Conditional_Delay (Full, Priv);
- Set_Sloc (Full, Sloc (Priv));
- end case;
+ end Check_Digits_Expression;
- Set_Next_Entity (Full, Save_Next_Entity);
- Set_Homonym (Full, Save_Homonym);
- Set_Associated_Node_For_Itype (Full, Related_Nod);
+ --------------------------
+ -- Check_Initialization --
+ --------------------------
- -- Set common attributes for all subtypes: kind, convention, etc.
+ procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
+ begin
+ -- Special processing for limited types
- Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
- Set_Convention (Full, Convention (Full_Base));
+ if Is_Limited_Type (T)
+ and then not In_Instance
+ and then not In_Inlined_Body
+ then
+ if not OK_For_Limited_Init (T, Exp) then
- -- The Etype of the full view is inconsistent. Gigi needs to see the
- -- structural full view, which is what the current scheme gives:
- -- the Etype of the full view is the etype of the full base. However,
- -- if the full base is a derived type, the full view then looks like
- -- a subtype of the parent, not a subtype of the full base. If instead
- -- we write:
+ -- In GNAT mode, this is just a warning, to allow it to be evilly
+ -- turned off. Otherwise it is a real error.
- -- Set_Etype (Full, Full_Base);
+ if GNAT_Mode then
+ Error_Msg_N
+ ("??cannot initialize entities of limited type!", Exp);
- -- then we get inconsistencies in the front-end (confusion between
- -- views). Several outstanding bugs are related to this ???
+ elsif Ada_Version < Ada_2005 then
- Set_Is_First_Subtype (Full, False);
- Set_Scope (Full, Scope (Priv));
- Set_Size_Info (Full, Full_Base);
- Set_RM_Size (Full, RM_Size (Full_Base));
- Set_Is_Itype (Full);
+ -- The side effect removal machinery may generate illegal Ada
+ -- code to avoid the usage of access types and 'reference in
+ -- SPARK mode. Since this is legal code with respect to theorem
+ -- proving, do not emit the error.
- -- A subtype of a private-type-without-discriminants, whose full-view
- -- has discriminants with default expressions, is not constrained.
+ if GNATprove_Mode
+ and then Nkind (Exp) = N_Function_Call
+ and then Nkind (Parent (Exp)) = N_Object_Declaration
+ and then not Comes_From_Source
+ (Defining_Identifier (Parent (Exp)))
+ then
+ null;
- if not Has_Discriminants (Priv) then
- Set_Is_Constrained (Full, Is_Constrained (Full_Base));
+ else
+ Error_Msg_N
+ ("cannot initialize entities of limited type", Exp);
+ Explain_Limited_Type (T, Exp);
+ end if;
- if Has_Discriminants (Full_Base) then
- Set_Discriminant_Constraint
- (Full, Discriminant_Constraint (Full_Base));
+ else
+ -- Specialize error message according to kind of illegal
+ -- initial expression.
- -- The partial view may have been indefinite, the full view
- -- might not be.
+ if Nkind (Exp) = N_Type_Conversion
+ and then Nkind (Expression (Exp)) = N_Function_Call
+ then
+ Error_Msg_N
+ ("illegal context for call"
+ & " to function with limited result", Exp);
- Set_Has_Unknown_Discriminants
- (Full, Has_Unknown_Discriminants (Full_Base));
+ else
+ Error_Msg_N
+ ("initialization of limited object requires aggregate "
+ & "or function call", Exp);
+ end if;
+ end if;
end if;
end if;
- Set_First_Rep_Item (Full, First_Rep_Item (Full_Base));
- Set_Depends_On_Private (Full, Has_Private_Component (Full));
+ -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets
+ -- set unless we can be sure that no range check is required.
- -- Freeze the private subtype entity if its parent is delayed, and not
- -- already frozen. We skip this processing if the type is an anonymous
- -- subtype of a record component, or is the corresponding record of a
- -- protected type, since ???
-
- if not Is_Type (Scope (Full)) then
- Set_Has_Delayed_Freeze (Full,
- Has_Delayed_Freeze (Full_Base)
- and then (not Is_Frozen (Full_Base)));
- end if;
-
- Set_Freeze_Node (Full, Empty);
- Set_Is_Frozen (Full, False);
- Set_Full_View (Priv, Full);
-
- if Has_Discriminants (Full) then
- Set_Stored_Constraint_From_Discriminant_Constraint (Full);
- Set_Stored_Constraint (Priv, Stored_Constraint (Full));
-
- if Has_Unknown_Discriminants (Full) then
- Set_Discriminant_Constraint (Full, No_Elist);
- end if;
+ if (GNATprove_Mode or not Expander_Active)
+ and then Is_Scalar_Type (T)
+ and then not Is_In_Range (Exp, T, Assume_Valid => True)
+ then
+ Set_Do_Range_Check (Exp);
end if;
+ end Check_Initialization;
- if Ekind (Full_Base) = E_Record_Type
- and then Has_Discriminants (Full_Base)
- and then Has_Discriminants (Priv) -- might not, if errors
- and then not Has_Unknown_Discriminants (Priv)
- and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
- then
- Create_Constrained_Components
- (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
+ ----------------------
+ -- Check_Interfaces --
+ ----------------------
- -- If the full base is itself derived from private, build a congruent
- -- subtype of its underlying type, for use by the back end. For a
- -- constrained record component, the declaration cannot be placed on
- -- the component list, but it must nevertheless be built an analyzed, to
- -- supply enough information for Gigi to compute the size of component.
+ procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is
+ Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N));
- elsif Ekind (Full_Base) in Private_Kind
- and then Is_Derived_Type (Full_Base)
- and then Has_Discriminants (Full_Base)
- and then (Ekind (Current_Scope) /= E_Record_Subtype)
- then
- if not Is_Itype (Priv)
- and then
- Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
- then
- Build_Underlying_Full_View
- (Parent (Priv), Full, Etype (Full_Base));
+ Iface : Node_Id;
+ Iface_Def : Node_Id;
+ Iface_Typ : Entity_Id;
+ Parent_Node : Node_Id;
- elsif Nkind (Related_Nod) = N_Component_Declaration then
- Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
- end if;
+ Is_Task : Boolean := False;
+ -- Set True if parent type or any progenitor is a task interface
- elsif Is_Record_Type (Full_Base) then
+ Is_Protected : Boolean := False;
+ -- Set True if parent type or any progenitor is a protected interface
- -- Show Full is simply a renaming of Full_Base
+ procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
+ -- Check that a progenitor is compatible with declaration. If an error
+ -- message is output, it is posted on Error_Node.
- Set_Cloned_Subtype (Full, Full_Base);
- end if;
+ ------------------
+ -- Check_Ifaces --
+ ------------------
- -- It is unsafe to share the bounds of a scalar type, because the Itype
- -- is elaborated on demand, and if a bound is non-static then different
- -- orders of elaboration in different units will lead to different
- -- external symbols.
+ procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
+ Iface_Id : constant Entity_Id :=
+ Defining_Identifier (Parent (Iface_Def));
+ Type_Def : Node_Id;
- if Is_Scalar_Type (Full_Base) then
- Set_Scalar_Range (Full,
- Make_Range (Sloc (Related_Nod),
- Low_Bound =>
- Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)),
- High_Bound =>
- Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base))));
+ begin
+ if Nkind (N) = N_Private_Extension_Declaration then
+ Type_Def := N;
+ else
+ Type_Def := Type_Definition (N);
+ end if;
- -- This completion inherits the bounds of the full parent, but if
- -- the parent is an unconstrained floating point type, so is the
- -- completion.
+ if Is_Task_Interface (Iface_Id) then
+ Is_Task := True;
- if Is_Floating_Point_Type (Full_Base) then
- Set_Includes_Infinities
- (Scalar_Range (Full), Has_Infinities (Full_Base));
+ elsif Is_Protected_Interface (Iface_Id) then
+ Is_Protected := True;
end if;
- end if;
- -- ??? It seems that a lot of fields are missing that should be copied
- -- from Full_Base to Full. Here are some that are introduced in a
- -- non-disruptive way but a cleanup is necessary.
+ if Is_Synchronized_Interface (Iface_Id) then
- if Is_Tagged_Type (Full_Base) then
- Set_Is_Tagged_Type (Full);
- Set_Direct_Primitive_Operations (Full,
- Direct_Primitive_Operations (Full_Base));
+ -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
+ -- extension derived from a synchronized interface must explicitly
+ -- be declared synchronized, because the full view will be a
+ -- synchronized type.
- -- Inherit class_wide type of full_base in case the partial view was
- -- not tagged. Otherwise it has already been created when the private
- -- subtype was analyzed.
+ if Nkind (N) = N_Private_Extension_Declaration then
+ if not Synchronized_Present (N) then
+ Error_Msg_NE
+ ("private extension of& must be explicitly synchronized",
+ N, Iface_Id);
+ end if;
- if No (Class_Wide_Type (Full)) then
- Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base));
+ -- However, by 3.9.4(16/2), a full type that is a record extension
+ -- is never allowed to derive from a synchronized interface (note
+ -- that interfaces must be excluded from this check, because those
+ -- are represented by derived type definitions in some cases).
+
+ elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition
+ and then not Interface_Present (Type_Definition (N))
+ then
+ Error_Msg_N ("record extension cannot derive from synchronized "
+ & "interface", Error_Node);
+ end if;
end if;
- -- If this is a subtype of a protected or task type, constrain its
- -- corresponding record, unless this is a subtype without constraints,
- -- i.e. a simple renaming as with an actual subtype in an instance.
+ -- Check that the characteristics of the progenitor are compatible
+ -- with the explicit qualifier in the declaration.
+ -- The check only applies to qualifiers that come from source.
+ -- Limited_Present also appears in the declaration of corresponding
+ -- records, and the check does not apply to them.
- elsif Is_Concurrent_Type (Full_Base) then
- if Has_Discriminants (Full)
- and then Present (Corresponding_Record_Type (Full_Base))
- and then
- not Is_Empty_Elmt_List (Discriminant_Constraint (Full))
+ if Limited_Present (Type_Def)
+ and then not
+ Is_Concurrent_Record_Type (Defining_Identifier (N))
then
- Set_Corresponding_Record_Type (Full,
- Constrain_Corresponding_Record
- (Full, Corresponding_Record_Type (Full_Base), Related_Nod));
+ if Is_Limited_Interface (Parent_Type)
+ and then not Is_Limited_Interface (Iface_Id)
+ then
+ Error_Msg_NE
+ ("progenitor & must be limited interface",
+ Error_Node, Iface_Id);
- else
- Set_Corresponding_Record_Type (Full,
- Corresponding_Record_Type (Full_Base));
- end if;
- end if;
+ elsif
+ (Task_Present (Iface_Def)
+ or else Protected_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def))
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ and then not Error_Posted (N)
+ then
+ Error_Msg_NE
+ ("progenitor & must be limited interface",
+ Error_Node, Iface_Id);
+ end if;
- -- Link rep item chain, and also setting of Has_Predicates from private
- -- subtype to full subtype, since we will need these on the full subtype
- -- to create the predicate function. Note that the full subtype may
- -- already have rep items, inherited from the full view of the base
- -- type, so we must be sure not to overwrite these entries.
+ -- Protected interfaces can only inherit from limited, synchronized
+ -- or protected interfaces.
- declare
- Append : Boolean;
- Item : Node_Id;
- Next_Item : Node_Id;
+ elsif Nkind (N) = N_Full_Type_Declaration
+ and then Protected_Present (Type_Def)
+ then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Protected_Present (Iface_Def)
+ then
+ null;
- begin
- Item := First_Rep_Item (Full);
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) protected interface cannot inherit "
+ & "from task interface", Error_Node);
- -- If no existing rep items on full type, we can just link directly
- -- to the list of items on the private type.
+ else
+ Error_Msg_N ("(Ada 2005) protected interface cannot inherit "
+ & "from non-limited interface", Error_Node);
+ end if;
- if No (Item) then
- Set_First_Rep_Item (Full, First_Rep_Item (Priv));
+ -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from
+ -- limited and synchronized.
- -- Otherwise, search to the end of items currently linked to the full
- -- subtype and append the private items to the end. However, if Priv
- -- and Full already have the same list of rep items, then the append
- -- is not done, as that would create a circularity.
+ elsif Synchronized_Present (Type_Def) then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ then
+ null;
- elsif Item /= First_Rep_Item (Priv) then
- Append := True;
+ elsif Protected_Present (Iface_Def)
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ then
+ Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit "
+ & "from protected interface", Error_Node);
- loop
- Next_Item := Next_Rep_Item (Item);
- exit when No (Next_Item);
- Item := Next_Item;
+ elsif Task_Present (Iface_Def)
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ then
+ Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit "
+ & "from task interface", Error_Node);
- -- If the private view has aspect specifications, the full view
- -- inherits them. Since these aspects may already have been
- -- attached to the full view during derivation, do not append
- -- them if already present.
+ elsif not Is_Limited_Interface (Iface_Id) then
+ Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit "
+ & "from non-limited interface", Error_Node);
+ end if;
- if Item = First_Rep_Item (Priv) then
- Append := False;
- exit;
- end if;
- end loop;
+ -- Ada 2005 (AI-345): Task interfaces can only inherit from limited,
+ -- synchronized or task interfaces.
- -- And link the private type items at the end of the chain
+ elsif Nkind (N) = N_Full_Type_Declaration
+ and then Task_Present (Type_Def)
+ then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Task_Present (Iface_Def)
+ then
+ null;
- if Append then
- Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) task interface cannot inherit from "
+ & "protected interface", Error_Node);
+
+ else
+ Error_Msg_N ("(Ada 2005) task interface cannot inherit from "
+ & "non-limited interface", Error_Node);
end if;
end if;
- end;
+ end Check_Ifaces;
- -- Make sure Has_Predicates is set on full type if it is set on the
- -- private type. Note that it may already be set on the full type and
- -- if so, we don't want to unset it.
+ -- Start of processing for Check_Interfaces
- if Has_Predicates (Priv) then
- Set_Has_Predicates (Full);
- end if;
- end Complete_Private_Subtype;
+ begin
+ if Is_Interface (Parent_Type) then
+ if Is_Task_Interface (Parent_Type) then
+ Is_Task := True;
- ----------------------------
- -- Constant_Redeclaration --
- ----------------------------
+ elsif Is_Protected_Interface (Parent_Type) then
+ Is_Protected := True;
+ end if;
+ end if;
- procedure Constant_Redeclaration
- (Id : Entity_Id;
- N : Node_Id;
- T : out Entity_Id)
- is
- Prev : constant Entity_Id := Current_Entity_In_Scope (Id);
- Obj_Def : constant Node_Id := Object_Definition (N);
- New_T : Entity_Id;
+ if Nkind (N) = N_Private_Extension_Declaration then
- procedure Check_Possible_Deferred_Completion
- (Prev_Id : Entity_Id;
- Prev_Obj_Def : Node_Id;
- Curr_Obj_Def : Node_Id);
- -- Determine whether the two object definitions describe the partial
- -- and the full view of a constrained deferred constant. Generate
- -- a subtype for the full view and verify that it statically matches
- -- the subtype of the partial view.
+ -- Check that progenitors are compatible with declaration
- procedure Check_Recursive_Declaration (Typ : Entity_Id);
- -- If deferred constant is an access type initialized with an allocator,
- -- check whether there is an illegal recursion in the definition,
- -- through a default value of some record subcomponent. This is normally
- -- detected when generating init procs, but requires this additional
- -- mechanism when expansion is disabled.
+ Iface := First (Interface_List (Def));
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
- ----------------------------------------
- -- Check_Possible_Deferred_Completion --
- ----------------------------------------
+ Parent_Node := Parent (Base_Type (Iface_Typ));
+ Iface_Def := Type_Definition (Parent_Node);
- procedure Check_Possible_Deferred_Completion
- (Prev_Id : Entity_Id;
- Prev_Obj_Def : Node_Id;
- Curr_Obj_Def : Node_Id)
- is
- begin
- if Nkind (Prev_Obj_Def) = N_Subtype_Indication
- and then Present (Constraint (Prev_Obj_Def))
- and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
- and then Present (Constraint (Curr_Obj_Def))
- then
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
- Decl : constant Node_Id :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Indication =>
- Relocate_Node (Curr_Obj_Def));
+ if not Is_Interface (Iface_Typ) then
+ Diagnose_Interface (Iface, Iface_Typ);
+ else
+ Check_Ifaces (Iface_Def, Iface);
+ end if;
- begin
- Insert_Before_And_Analyze (N, Decl);
- Set_Etype (Id, Def_Id);
+ Next (Iface);
+ end loop;
- if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
- Error_Msg_Sloc := Sloc (Prev_Id);
- Error_Msg_N ("subtype does not statically match deferred " &
- "declaration#", N);
- end if;
- end;
+ if Is_Task and Is_Protected then
+ Error_Msg_N
+ ("type cannot derive from task and protected interface", N);
end if;
- end Check_Possible_Deferred_Completion;
-
- ---------------------------------
- -- Check_Recursive_Declaration --
- ---------------------------------
-
- procedure Check_Recursive_Declaration (Typ : Entity_Id) is
- Comp : Entity_Id;
- begin
- if Is_Record_Type (Typ) then
- Comp := First_Component (Typ);
- while Present (Comp) loop
- if Comes_From_Source (Comp) then
- if Present (Expression (Parent (Comp)))
- and then Is_Entity_Name (Expression (Parent (Comp)))
- and then Entity (Expression (Parent (Comp))) = Prev
- then
- Error_Msg_Sloc := Sloc (Parent (Comp));
- Error_Msg_NE
- ("illegal circularity with declaration for&#",
- N, Comp);
- return;
+ return;
+ end if;
- elsif Is_Record_Type (Etype (Comp)) then
- Check_Recursive_Declaration (Etype (Comp));
- end if;
- end if;
+ -- Full type declaration of derived type.
+ -- Check compatibility with parent if it is interface type
- Next_Component (Comp);
- end loop;
- end if;
- end Check_Recursive_Declaration;
+ if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
+ and then Is_Interface (Parent_Type)
+ then
+ Parent_Node := Parent (Parent_Type);
- -- Start of processing for Constant_Redeclaration
+ -- More detailed checks for interface varieties
- begin
- if Nkind (Parent (Prev)) = N_Object_Declaration then
- if Nkind (Object_Definition
- (Parent (Prev))) = N_Subtype_Indication
- then
- -- Find type of new declaration. The constraints of the two
- -- views must match statically, but there is no point in
- -- creating an itype for the full view.
+ Check_Ifaces
+ (Iface_Def => Type_Definition (Parent_Node),
+ Error_Node => Subtype_Indication (Type_Definition (N)));
+ end if;
- if Nkind (Obj_Def) = N_Subtype_Indication then
- Find_Type (Subtype_Mark (Obj_Def));
- New_T := Entity (Subtype_Mark (Obj_Def));
+ Iface := First (Interface_List (Def));
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
- else
- Find_Type (Obj_Def);
- New_T := Entity (Obj_Def);
- end if;
+ Parent_Node := Parent (Base_Type (Iface_Typ));
+ Iface_Def := Type_Definition (Parent_Node);
- T := Etype (Prev);
+ if not Is_Interface (Iface_Typ) then
+ Diagnose_Interface (Iface, Iface_Typ);
else
- -- The full view may impose a constraint, even if the partial
- -- view does not, so construct the subtype.
+ -- "The declaration of a specific descendant of an interface
+ -- type freezes the interface type" RM 13.14
- New_T := Find_Type_Of_Object (Obj_Def, N);
- T := New_T;
+ Freeze_Before (N, Iface_Typ);
+ Check_Ifaces (Iface_Def, Error_Node => Iface);
end if;
- else
- -- Current declaration is illegal, diagnosed below in Enter_Name
+ Next (Iface);
+ end loop;
- T := Empty;
- New_T := Any_Type;
+ if Is_Task and Is_Protected then
+ Error_Msg_N
+ ("type cannot derive from task and protected interface", N);
end if;
+ end Check_Interfaces;
- -- If previous full declaration or a renaming declaration exists, or if
- -- a homograph is present, let Enter_Name handle it, either with an
- -- error or with the removal of an overridden implicit subprogram.
- -- The previous one is a full declaration if it has an expression
- -- (which in the case of an aggregate is indicated by the Init flag).
-
- if Ekind (Prev) /= E_Constant
- or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration
- or else Present (Expression (Parent (Prev)))
- or else Has_Init_Expression (Parent (Prev))
- or else Present (Full_View (Prev))
- then
- Enter_Name (Id);
-
- -- Verify that types of both declarations match, or else that both types
- -- are anonymous access types whose designated subtypes statically match
- -- (as allowed in Ada 2005 by AI-385).
+ ------------------------------------
+ -- Check_Or_Process_Discriminants --
+ ------------------------------------
- elsif Base_Type (Etype (Prev)) /= Base_Type (New_T)
- and then
- (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type
- or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type
- or else Is_Access_Constant (Etype (New_T)) /=
- Is_Access_Constant (Etype (Prev))
- or else Can_Never_Be_Null (Etype (New_T)) /=
- Can_Never_Be_Null (Etype (Prev))
- or else Null_Exclusion_Present (Parent (Prev)) /=
- Null_Exclusion_Present (Parent (Id))
- or else not Subtypes_Statically_Match
- (Designated_Type (Etype (Prev)),
- Designated_Type (Etype (New_T))))
- then
- Error_Msg_Sloc := Sloc (Prev);
- Error_Msg_N ("type does not match declaration#", N);
- Set_Full_View (Prev, Id);
- Set_Etype (Id, Any_Type);
+ -- If an incomplete or private type declaration was already given for the
+ -- type, the discriminants may have already been processed if they were
+ -- present on the incomplete declaration. In this case a full conformance
+ -- check has been performed in Find_Type_Name, and we then recheck here
+ -- some properties that can't be checked on the partial view alone.
+ -- Otherwise we call Process_Discriminants.
- elsif
- Null_Exclusion_Present (Parent (Prev))
- and then not Null_Exclusion_Present (N)
- then
- Error_Msg_Sloc := Sloc (Prev);
- Error_Msg_N ("null-exclusion does not match declaration#", N);
- Set_Full_View (Prev, Id);
- Set_Etype (Id, Any_Type);
+ procedure Check_Or_Process_Discriminants
+ (N : Node_Id;
+ T : Entity_Id;
+ Prev : Entity_Id := Empty)
+ is
+ begin
+ if Has_Discriminants (T) then
- -- If so, process the full constant declaration
+ -- Discriminants are already set on T if they were already present
+ -- on the partial view. Make them visible to component declarations.
- else
- -- RM 7.4 (6): If the subtype defined by the subtype_indication in
- -- the deferred declaration is constrained, then the subtype defined
- -- by the subtype_indication in the full declaration shall match it
- -- statically.
+ declare
+ D : Entity_Id;
+ -- Discriminant on T (full view) referencing expr on partial view
- Check_Possible_Deferred_Completion
- (Prev_Id => Prev,
- Prev_Obj_Def => Object_Definition (Parent (Prev)),
- Curr_Obj_Def => Obj_Def);
+ Prev_D : Entity_Id;
+ -- Entity of corresponding discriminant on partial view
- Set_Full_View (Prev, Id);
- Set_Is_Public (Id, Is_Public (Prev));
- Set_Is_Internal (Id);
- Append_Entity (Id, Current_Scope);
+ New_D : Node_Id;
+ -- Discriminant specification for full view, expression is
+ -- the syntactic copy on full view (which has been checked for
+ -- conformance with partial view), only used here to post error
+ -- message.
- -- Check ALIASED present if present before (RM 7.4(7))
+ begin
+ D := First_Discriminant (T);
+ New_D := First (Discriminant_Specifications (N));
+ while Present (D) loop
+ Prev_D := Current_Entity (D);
+ Set_Current_Entity (D);
+ Set_Is_Immediately_Visible (D);
+ Set_Homonym (D, Prev_D);
- if Is_Aliased (Prev)
- and then not Aliased_Present (N)
- then
- Error_Msg_Sloc := Sloc (Prev);
- Error_Msg_N ("ALIASED required (see declaration#)", N);
- end if;
+ -- Handle the case where there is an untagged partial view and
+ -- the full view is tagged: must disallow discriminants with
+ -- defaults, unless compiling for Ada 2012, which allows a
+ -- limited tagged type to have defaulted discriminants (see
+ -- AI05-0214). However, suppress error here if it was already
+ -- reported on the default expression of the partial view.
- -- Check that placement is in private part and that the incomplete
- -- declaration appeared in the visible part.
+ if Is_Tagged_Type (T)
+ and then Present (Expression (Parent (D)))
+ and then (not Is_Limited_Type (Current_Scope)
+ or else Ada_Version < Ada_2012)
+ and then not Error_Posted (Expression (Parent (D)))
+ then
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_N
+ ("discriminants of nonlimited tagged type cannot have "
+ & "defaults",
+ Expression (New_D));
+ else
+ Error_Msg_N
+ ("discriminants of tagged type cannot have defaults",
+ Expression (New_D));
+ end if;
+ end if;
- if Ekind (Current_Scope) = E_Package
- and then not In_Private_Part (Current_Scope)
- then
- Error_Msg_Sloc := Sloc (Prev);
- Error_Msg_N
- ("full constant for declaration#"
- & " must be in private part", N);
+ -- Ada 2005 (AI-230): Access discriminant allowed in
+ -- non-limited record types.
- elsif Ekind (Current_Scope) = E_Package
- and then
- List_Containing (Parent (Prev)) /=
- Visible_Declarations (Package_Specification (Current_Scope))
- then
- Error_Msg_N
- ("deferred constant must be declared in visible part",
- Parent (Prev));
- end if;
+ if Ada_Version < Ada_2005 then
- if Is_Access_Type (T)
- and then Nkind (Expression (N)) = N_Allocator
- then
- Check_Recursive_Declaration (Designated_Type (T));
- end if;
+ -- This restriction gets applied to the full type here. It
+ -- has already been applied earlier to the partial view.
- -- A deferred constant is a visible entity. If type has invariants,
- -- verify that the initial value satisfies them.
+ Check_Access_Discriminant_Requires_Limited (Parent (D), N);
+ end if;
- if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then
- Insert_After (N,
- Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N))));
- end if;
+ Next_Discriminant (D);
+ Next (New_D);
+ end loop;
+ end;
+
+ elsif Present (Discriminant_Specifications (N)) then
+ Process_Discriminants (N, Prev);
end if;
- end Constant_Redeclaration;
+ end Check_Or_Process_Discriminants;
----------------------
- -- Constrain_Access --
+ -- Check_Real_Bound --
----------------------
- procedure Constrain_Access
- (Def_Id : in out Entity_Id;
- S : Node_Id;
- Related_Nod : Node_Id)
- is
- T : constant Entity_Id := Entity (Subtype_Mark (S));
- Desig_Type : constant Entity_Id := Designated_Type (T);
- Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
- Constraint_OK : Boolean := True;
-
+ procedure Check_Real_Bound (Bound : Node_Id) is
begin
- if Is_Array_Type (Desig_Type) then
- Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
+ if not Is_Real_Type (Etype (Bound)) then
+ Error_Msg_N
+ ("bound in real type definition must be of real type", Bound);
- elsif (Is_Record_Type (Desig_Type)
- or else Is_Incomplete_Or_Private_Type (Desig_Type))
- and then not Is_Constrained (Desig_Type)
- then
- -- ??? The following code is a temporary bypass to ignore a
- -- discriminant constraint on access type if it is constraining
- -- the current record. Avoid creating the implicit subtype of the
- -- record we are currently compiling since right now, we cannot
- -- handle these. For now, just return the access type itself.
+ elsif not Is_OK_Static_Expression (Bound) then
+ Flag_Non_Static_Expr
+ ("non-static expression used for real type bound!", Bound);
- if Desig_Type = Current_Scope
- and then No (Def_Id)
- then
- Set_Ekind (Desig_Subtype, E_Record_Subtype);
- Def_Id := Entity (Subtype_Mark (S));
+ else
+ return;
+ end if;
- -- This call added to ensure that the constraint is analyzed
- -- (needed for a B test). Note that we still return early from
- -- this procedure to avoid recursive processing. ???
+ Rewrite
+ (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
+ Analyze (Bound);
+ Resolve (Bound, Standard_Float);
+ end Check_Real_Bound;
- Constrain_Discriminated_Type
- (Desig_Subtype, S, Related_Nod, For_Access => True);
- return;
- end if;
+ ------------------------------
+ -- Complete_Private_Subtype --
+ ------------------------------
- -- Enforce rule that the constraint is illegal if there is an
- -- unconstrained view of the designated type. This means that the
- -- partial view (either a private type declaration or a derivation
- -- from a private type) has no discriminants. (Defect Report
- -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001).
+ procedure Complete_Private_Subtype
+ (Priv : Entity_Id;
+ Full : Entity_Id;
+ Full_Base : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ Save_Next_Entity : Entity_Id;
+ Save_Homonym : Entity_Id;
- -- Rule updated for Ada 2005: The private type is said to have
- -- a constrained partial view, given that objects of the type
- -- can be declared. Furthermore, the rule applies to all access
- -- types, unlike the rule concerning default discriminants (see
- -- RM 3.7.1(7/3))
+ begin
+ -- Set semantic attributes for (implicit) private subtype completion.
+ -- If the full type has no discriminants, then it is a copy of the
+ -- full view of the base. Otherwise, it is a subtype of the base with
+ -- a possible discriminant constraint. Save and restore the original
+ -- Next_Entity field of full to ensure that the calls to Copy_Node do
+ -- not corrupt the entity chain.
+
+ -- Note that the type of the full view is the same entity as the type
+ -- of the partial view. In this fashion, the subtype has access to the
+ -- correct view of the parent.
- if (Ekind (T) = E_General_Access_Type
- or else Ada_Version >= Ada_2005)
- and then Has_Private_Declaration (Desig_Type)
- and then In_Open_Scopes (Scope (Desig_Type))
- and then Has_Discriminants (Desig_Type)
- then
- declare
- Pack : constant Node_Id :=
- Unit_Declaration_Node (Scope (Desig_Type));
- Decls : List_Id;
- Decl : Node_Id;
+ Save_Next_Entity := Next_Entity (Full);
+ Save_Homonym := Homonym (Priv);
- begin
- if Nkind (Pack) = N_Package_Declaration then
- Decls := Visible_Declarations (Specification (Pack));
- Decl := First (Decls);
- while Present (Decl) loop
- if (Nkind (Decl) = N_Private_Type_Declaration
- and then
- Chars (Defining_Identifier (Decl)) =
- Chars (Desig_Type))
+ case Ekind (Full_Base) is
+ when E_Record_Type |
+ E_Record_Subtype |
+ Class_Wide_Kind |
+ Private_Kind |
+ Task_Kind |
+ Protected_Kind =>
+ Copy_Node (Priv, Full);
- or else
- (Nkind (Decl) = N_Full_Type_Declaration
- and then
- Chars (Defining_Identifier (Decl)) =
- Chars (Desig_Type)
- and then Is_Derived_Type (Desig_Type)
- and then
- Has_Private_Declaration (Etype (Desig_Type)))
- then
- if No (Discriminant_Specifications (Decl)) then
- Error_Msg_N
- ("cannot constrain access type if designated " &
- "type has constrained partial view", S);
- end if;
+ Set_Has_Discriminants
+ (Full, Has_Discriminants (Full_Base));
+ Set_Has_Unknown_Discriminants
+ (Full, Has_Unknown_Discriminants (Full_Base));
+ Set_First_Entity (Full, First_Entity (Full_Base));
+ Set_Last_Entity (Full, Last_Entity (Full_Base));
- exit;
- end if;
+ -- If the underlying base type is constrained, we know that the
+ -- full view of the subtype is constrained as well (the converse
+ -- is not necessarily true).
- Next (Decl);
- end loop;
- end if;
- end;
- end if;
+ if Is_Constrained (Full_Base) then
+ Set_Is_Constrained (Full);
+ end if;
- Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
- For_Access => True);
+ when others =>
+ Copy_Node (Full_Base, Full);
- elsif (Is_Task_Type (Desig_Type)
- or else Is_Protected_Type (Desig_Type))
- and then not Is_Constrained (Desig_Type)
- then
- Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
+ Set_Chars (Full, Chars (Priv));
+ Conditional_Delay (Full, Priv);
+ Set_Sloc (Full, Sloc (Priv));
+ end case;
- else
- Error_Msg_N ("invalid constraint on access type", S);
- Desig_Subtype := Desig_Type; -- Ignore invalid constraint.
- Constraint_OK := False;
- end if;
+ Set_Next_Entity (Full, Save_Next_Entity);
+ Set_Homonym (Full, Save_Homonym);
+ Set_Associated_Node_For_Itype (Full, Related_Nod);
- if No (Def_Id) then
- Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
- else
- Set_Ekind (Def_Id, E_Access_Subtype);
- end if;
+ -- Set common attributes for all subtypes: kind, convention, etc.
- if Constraint_OK then
- Set_Etype (Def_Id, Base_Type (T));
+ Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
+ Set_Convention (Full, Convention (Full_Base));
- if Is_Private_Type (Desig_Type) then
- Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
- end if;
- else
- Set_Etype (Def_Id, Any_Type);
- end if;
+ -- The Etype of the full view is inconsistent. Gigi needs to see the
+ -- structural full view, which is what the current scheme gives: the
+ -- Etype of the full view is the etype of the full base. However, if the
+ -- full base is a derived type, the full view then looks like a subtype
+ -- of the parent, not a subtype of the full base. If instead we write:
- Set_Size_Info (Def_Id, T);
- Set_Is_Constrained (Def_Id, Constraint_OK);
- Set_Directly_Designated_Type (Def_Id, Desig_Subtype);
- Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
- Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T));
+ -- Set_Etype (Full, Full_Base);
- Conditional_Delay (Def_Id, T);
+ -- then we get inconsistencies in the front-end (confusion between
+ -- views). Several outstanding bugs are related to this ???
- -- AI-363 : Subtypes of general access types whose designated types have
- -- default discriminants are disallowed. In instances, the rule has to
- -- be checked against the actual, of which T is the subtype. In a
- -- generic body, the rule is checked assuming that the actual type has
- -- defaulted discriminants.
+ Set_Is_First_Subtype (Full, False);
+ Set_Scope (Full, Scope (Priv));
+ Set_Size_Info (Full, Full_Base);
+ Set_RM_Size (Full, RM_Size (Full_Base));
+ Set_Is_Itype (Full);
- if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then
- if Ekind (Base_Type (T)) = E_General_Access_Type
- and then Has_Defaulted_Discriminants (Desig_Type)
- then
- if Ada_Version < Ada_2005 then
- Error_Msg_N
- ("access subtype of general access type would not " &
- "be allowed in Ada 2005?y?", S);
- else
- Error_Msg_N
- ("access subtype of general access type not allowed", S);
- end if;
+ -- A subtype of a private-type-without-discriminants, whose full-view
+ -- has discriminants with default expressions, is not constrained.
- Error_Msg_N ("\discriminants have defaults", S);
+ if not Has_Discriminants (Priv) then
+ Set_Is_Constrained (Full, Is_Constrained (Full_Base));
- elsif Is_Access_Type (T)
- and then Is_Generic_Type (Desig_Type)
- and then Has_Discriminants (Desig_Type)
- and then In_Package_Body (Current_Scope)
- then
- if Ada_Version < Ada_2005 then
- Error_Msg_N
- ("access subtype would not be allowed in generic body " &
- "in Ada 2005?y?", S);
- else
- Error_Msg_N
- ("access subtype not allowed in generic body", S);
- end if;
+ if Has_Discriminants (Full_Base) then
+ Set_Discriminant_Constraint
+ (Full, Discriminant_Constraint (Full_Base));
- Error_Msg_N
- ("\designated type is a discriminated formal", S);
+ -- The partial view may have been indefinite, the full view
+ -- might not be.
+
+ Set_Has_Unknown_Discriminants
+ (Full, Has_Unknown_Discriminants (Full_Base));
end if;
end if;
- end Constrain_Access;
-
- ---------------------
- -- Constrain_Array --
- ---------------------
- procedure Constrain_Array
- (Def_Id : in out Entity_Id;
- SI : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id;
- Suffix : Character)
- is
- C : constant Node_Id := Constraint (SI);
- Number_Of_Constraints : Nat := 0;
- Index : Node_Id;
- S, T : Entity_Id;
- Constraint_OK : Boolean := True;
+ Set_First_Rep_Item (Full, First_Rep_Item (Full_Base));
+ Set_Depends_On_Private (Full, Has_Private_Component (Full));
- begin
- T := Entity (Subtype_Mark (SI));
+ -- Freeze the private subtype entity if its parent is delayed, and not
+ -- already frozen. We skip this processing if the type is an anonymous
+ -- subtype of a record component, or is the corresponding record of a
+ -- protected type, since ???
- if Is_Access_Type (T) then
- T := Designated_Type (T);
+ if not Is_Type (Scope (Full)) then
+ Set_Has_Delayed_Freeze (Full,
+ Has_Delayed_Freeze (Full_Base)
+ and then (not Is_Frozen (Full_Base)));
end if;
- -- If an index constraint follows a subtype mark in a subtype indication
- -- then the type or subtype denoted by the subtype mark must not already
- -- impose an index constraint. The subtype mark must denote either an
- -- unconstrained array type or an access type whose designated type
- -- is such an array type... (RM 3.6.1)
+ Set_Freeze_Node (Full, Empty);
+ Set_Is_Frozen (Full, False);
+ Set_Full_View (Priv, Full);
- if Is_Constrained (T) then
- Error_Msg_N ("array type is already constrained", Subtype_Mark (SI));
- Constraint_OK := False;
+ if Has_Discriminants (Full) then
+ Set_Stored_Constraint_From_Discriminant_Constraint (Full);
+ Set_Stored_Constraint (Priv, Stored_Constraint (Full));
- else
- S := First (Constraints (C));
- while Present (S) loop
- Number_Of_Constraints := Number_Of_Constraints + 1;
- Next (S);
- end loop;
+ if Has_Unknown_Discriminants (Full) then
+ Set_Discriminant_Constraint (Full, No_Elist);
+ end if;
+ end if;
- -- In either case, the index constraint must provide a discrete
- -- range for each index of the array type and the type of each
- -- discrete range must be the same as that of the corresponding
- -- index. (RM 3.6.1)
+ if Ekind (Full_Base) = E_Record_Type
+ and then Has_Discriminants (Full_Base)
+ and then Has_Discriminants (Priv) -- might not, if errors
+ and then not Has_Unknown_Discriminants (Priv)
+ and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
+ then
+ Create_Constrained_Components
+ (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
- if Number_Of_Constraints /= Number_Dimensions (T) then
- Error_Msg_NE ("incorrect number of index constraints for }", C, T);
- Constraint_OK := False;
+ -- If the full base is itself derived from private, build a congruent
+ -- subtype of its underlying type, for use by the back end. For a
+ -- constrained record component, the declaration cannot be placed on
+ -- the component list, but it must nevertheless be built an analyzed, to
+ -- supply enough information for Gigi to compute the size of component.
- else
- S := First (Constraints (C));
- Index := First_Index (T);
- Analyze (Index);
+ elsif Ekind (Full_Base) in Private_Kind
+ and then Is_Derived_Type (Full_Base)
+ and then Has_Discriminants (Full_Base)
+ and then (Ekind (Current_Scope) /= E_Record_Subtype)
+ then
+ if not Is_Itype (Priv)
+ and then
+ Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
+ then
+ Build_Underlying_Full_View
+ (Parent (Priv), Full, Etype (Full_Base));
- -- Apply constraints to each index type
+ elsif Nkind (Related_Nod) = N_Component_Declaration then
+ Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
+ end if;
- for J in 1 .. Number_Of_Constraints loop
- Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
- Next (Index);
- Next (S);
- end loop;
+ elsif Is_Record_Type (Full_Base) then
- end if;
+ -- Show Full is simply a renaming of Full_Base
+
+ Set_Cloned_Subtype (Full, Full_Base);
end if;
- if No (Def_Id) then
- Def_Id :=
- Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
- Set_Parent (Def_Id, Related_Nod);
+ -- It is unsafe to share the bounds of a scalar type, because the Itype
+ -- is elaborated on demand, and if a bound is non-static then different
+ -- orders of elaboration in different units will lead to different
+ -- external symbols.
- else
- Set_Ekind (Def_Id, E_Array_Subtype);
- end if;
+ if Is_Scalar_Type (Full_Base) then
+ Set_Scalar_Range (Full,
+ Make_Range (Sloc (Related_Nod),
+ Low_Bound =>
+ Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)),
+ High_Bound =>
+ Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base))));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- Set_Etype (Def_Id, Base_Type (T));
+ -- This completion inherits the bounds of the full parent, but if
+ -- the parent is an unconstrained floating point type, so is the
+ -- completion.
- if Constraint_OK then
- Set_First_Index (Def_Id, First (Constraints (C)));
- else
- Set_First_Index (Def_Id, First_Index (T));
+ if Is_Floating_Point_Type (Full_Base) then
+ Set_Includes_Infinities
+ (Scalar_Range (Full), Has_Infinities (Full_Base));
+ end if;
end if;
- Set_Is_Constrained (Def_Id, True);
- Set_Is_Aliased (Def_Id, Is_Aliased (T));
- Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
-
- Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
- Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
+ -- ??? It seems that a lot of fields are missing that should be copied
+ -- from Full_Base to Full. Here are some that are introduced in a
+ -- non-disruptive way but a cleanup is necessary.
- -- A subtype does not inherit the Packed_Array_Impl_Type of is parent.
- -- We need to initialize the attribute because if Def_Id is previously
- -- analyzed through a limited_with clause, it will have the attributes
- -- of an incomplete type, one of which is an Elist that overlaps the
- -- Packed_Array_Impl_Type field.
+ if Is_Tagged_Type (Full_Base) then
+ Set_Is_Tagged_Type (Full);
+ Set_Direct_Primitive_Operations (Full,
+ Direct_Primitive_Operations (Full_Base));
- Set_Packed_Array_Impl_Type (Def_Id, Empty);
+ -- Inherit class_wide type of full_base in case the partial view was
+ -- not tagged. Otherwise it has already been created when the private
+ -- subtype was analyzed.
- -- Build a freeze node if parent still needs one. Also make sure that
- -- the Depends_On_Private status is set because the subtype will need
- -- reprocessing at the time the base type does, and also we must set a
- -- conditional delay.
+ if No (Class_Wide_Type (Full)) then
+ Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base));
+ end if;
- Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
- Conditional_Delay (Def_Id, T);
- end Constrain_Array;
+ -- If this is a subtype of a protected or task type, constrain its
+ -- corresponding record, unless this is a subtype without constraints,
+ -- i.e. a simple renaming as with an actual subtype in an instance.
- ------------------------------
- -- Constrain_Component_Type --
- ------------------------------
+ elsif Is_Concurrent_Type (Full_Base) then
+ if Has_Discriminants (Full)
+ and then Present (Corresponding_Record_Type (Full_Base))
+ and then
+ not Is_Empty_Elmt_List (Discriminant_Constraint (Full))
+ then
+ Set_Corresponding_Record_Type (Full,
+ Constrain_Corresponding_Record
+ (Full, Corresponding_Record_Type (Full_Base), Related_Nod));
- function Constrain_Component_Type
- (Comp : Entity_Id;
- Constrained_Typ : Entity_Id;
- Related_Node : Node_Id;
- Typ : Entity_Id;
- Constraints : Elist_Id) return Entity_Id
- is
- Loc : constant Source_Ptr := Sloc (Constrained_Typ);
- Compon_Type : constant Entity_Id := Etype (Comp);
+ else
+ Set_Corresponding_Record_Type (Full,
+ Corresponding_Record_Type (Full_Base));
+ end if;
+ end if;
- function Build_Constrained_Array_Type
- (Old_Type : Entity_Id) return Entity_Id;
- -- If Old_Type is an array type, one of whose indexes is constrained
- -- by a discriminant, build an Itype whose constraint replaces the
- -- discriminant with its value in the constraint.
+ -- Link rep item chain, and also setting of Has_Predicates from private
+ -- subtype to full subtype, since we will need these on the full subtype
+ -- to create the predicate function. Note that the full subtype may
+ -- already have rep items, inherited from the full view of the base
+ -- type, so we must be sure not to overwrite these entries.
- function Build_Constrained_Discriminated_Type
- (Old_Type : Entity_Id) return Entity_Id;
- -- Ditto for record components
-
- function Build_Constrained_Access_Type
- (Old_Type : Entity_Id) return Entity_Id;
- -- Ditto for access types. Makes use of previous two functions, to
- -- constrain designated type.
-
- function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
- -- T is an array or discriminated type, C is a list of constraints
- -- that apply to T. This routine builds the constrained subtype.
-
- function Is_Discriminant (Expr : Node_Id) return Boolean;
- -- Returns True if Expr is a discriminant
-
- function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
- -- Find the value of discriminant Discrim in Constraint
-
- -----------------------------------
- -- Build_Constrained_Access_Type --
- -----------------------------------
-
- function Build_Constrained_Access_Type
- (Old_Type : Entity_Id) return Entity_Id
- is
- Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
- Itype : Entity_Id;
- Desig_Subtype : Entity_Id;
- Scop : Entity_Id;
+ declare
+ Append : Boolean;
+ Item : Node_Id;
+ Next_Item : Node_Id;
begin
- -- if the original access type was not embedded in the enclosing
- -- type definition, there is no need to produce a new access
- -- subtype. In fact every access type with an explicit constraint
- -- generates an itype whose scope is the enclosing record.
-
- if not Is_Type (Scope (Old_Type)) then
- return Old_Type;
+ Item := First_Rep_Item (Full);
- elsif Is_Array_Type (Desig_Type) then
- Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
+ -- If no existing rep items on full type, we can just link directly
+ -- to the list of items on the private type.
- elsif Has_Discriminants (Desig_Type) then
+ if No (Item) then
+ Set_First_Rep_Item (Full, First_Rep_Item (Priv));
- -- This may be an access type to an enclosing record type for
- -- which we are constructing the constrained components. Return
- -- the enclosing record subtype. This is not always correct,
- -- but avoids infinite recursion. ???
+ -- Otherwise, search to the end of items currently linked to the full
+ -- subtype and append the private items to the end. However, if Priv
+ -- and Full already have the same list of rep items, then the append
+ -- is not done, as that would create a circularity.
- Desig_Subtype := Any_Type;
+ elsif Item /= First_Rep_Item (Priv) then
+ Append := True;
+ loop
+ Next_Item := Next_Rep_Item (Item);
+ exit when No (Next_Item);
+ Item := Next_Item;
- for J in reverse 0 .. Scope_Stack.Last loop
- Scop := Scope_Stack.Table (J).Entity;
+ -- If the private view has aspect specifications, the full view
+ -- inherits them. Since these aspects may already have been
+ -- attached to the full view during derivation, do not append
+ -- them if already present.
- if Is_Type (Scop)
- and then Base_Type (Scop) = Base_Type (Desig_Type)
- then
- Desig_Subtype := Scop;
+ if Item = First_Rep_Item (Priv) then
+ Append := False;
+ exit;
end if;
-
- exit when not Is_Type (Scop);
end loop;
- if Desig_Subtype = Any_Type then
- Desig_Subtype :=
- Build_Constrained_Discriminated_Type (Desig_Type);
- end if;
+ -- And link the private type items at the end of the chain
- else
- return Old_Type;
+ if Append then
+ Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
+ end if;
end if;
+ end;
- if Desig_Subtype /= Desig_Type then
-
- -- The Related_Node better be here or else we won't be able
- -- to attach new itypes to a node in the tree.
-
- pragma Assert (Present (Related_Node));
-
- Itype := Create_Itype (E_Access_Subtype, Related_Node);
+ -- Make sure Has_Predicates is set on full type if it is set on the
+ -- private type. Note that it may already be set on the full type and
+ -- if so, we don't want to unset it.
- Set_Etype (Itype, Base_Type (Old_Type));
- Set_Size_Info (Itype, (Old_Type));
- Set_Directly_Designated_Type (Itype, Desig_Subtype);
- Set_Depends_On_Private (Itype, Has_Private_Component
- (Old_Type));
- Set_Is_Access_Constant (Itype, Is_Access_Constant
- (Old_Type));
+ if Has_Predicates (Priv) then
+ Set_Has_Predicates (Full);
+ end if;
+ end Complete_Private_Subtype;
- -- The new itype needs freezing when it depends on a not frozen
- -- type and the enclosing subtype needs freezing.
+ ----------------------------
+ -- Constant_Redeclaration --
+ ----------------------------
- if Has_Delayed_Freeze (Constrained_Typ)
- and then not Is_Frozen (Constrained_Typ)
- then
- Conditional_Delay (Itype, Base_Type (Old_Type));
- end if;
+ procedure Constant_Redeclaration
+ (Id : Entity_Id;
+ N : Node_Id;
+ T : out Entity_Id)
+ is
+ Prev : constant Entity_Id := Current_Entity_In_Scope (Id);
+ Obj_Def : constant Node_Id := Object_Definition (N);
+ New_T : Entity_Id;
- return Itype;
+ procedure Check_Possible_Deferred_Completion
+ (Prev_Id : Entity_Id;
+ Prev_Obj_Def : Node_Id;
+ Curr_Obj_Def : Node_Id);
+ -- Determine whether the two object definitions describe the partial
+ -- and the full view of a constrained deferred constant. Generate
+ -- a subtype for the full view and verify that it statically matches
+ -- the subtype of the partial view.
- else
- return Old_Type;
- end if;
- end Build_Constrained_Access_Type;
+ procedure Check_Recursive_Declaration (Typ : Entity_Id);
+ -- If deferred constant is an access type initialized with an allocator,
+ -- check whether there is an illegal recursion in the definition,
+ -- through a default value of some record subcomponent. This is normally
+ -- detected when generating init procs, but requires this additional
+ -- mechanism when expansion is disabled.
- ----------------------------------
- -- Build_Constrained_Array_Type --
- ----------------------------------
+ ----------------------------------------
+ -- Check_Possible_Deferred_Completion --
+ ----------------------------------------
- function Build_Constrained_Array_Type
- (Old_Type : Entity_Id) return Entity_Id
+ procedure Check_Possible_Deferred_Completion
+ (Prev_Id : Entity_Id;
+ Prev_Obj_Def : Node_Id;
+ Curr_Obj_Def : Node_Id)
is
- Lo_Expr : Node_Id;
- Hi_Expr : Node_Id;
- Old_Index : Node_Id;
- Range_Node : Node_Id;
- Constr_List : List_Id;
-
- Need_To_Create_Itype : Boolean := False;
-
begin
- Old_Index := First_Index (Old_Type);
- while Present (Old_Index) loop
- Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
+ if Nkind (Prev_Obj_Def) = N_Subtype_Indication
+ and then Present (Constraint (Prev_Obj_Def))
+ and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
+ and then Present (Constraint (Curr_Obj_Def))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
+ Decl : constant Node_Id :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication =>
+ Relocate_Node (Curr_Obj_Def));
- if Is_Discriminant (Lo_Expr)
- or else Is_Discriminant (Hi_Expr)
- then
- Need_To_Create_Itype := True;
- end if;
+ begin
+ Insert_Before_And_Analyze (N, Decl);
+ Set_Etype (Id, Def_Id);
- Next_Index (Old_Index);
- end loop;
+ if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
+ Error_Msg_Sloc := Sloc (Prev_Id);
+ Error_Msg_N ("subtype does not statically match deferred "
+ & "declaration #", N);
+ end if;
+ end;
+ end if;
+ end Check_Possible_Deferred_Completion;
- if Need_To_Create_Itype then
- Constr_List := New_List;
+ ---------------------------------
+ -- Check_Recursive_Declaration --
+ ---------------------------------
- Old_Index := First_Index (Old_Type);
- while Present (Old_Index) loop
- Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
+ procedure Check_Recursive_Declaration (Typ : Entity_Id) is
+ Comp : Entity_Id;
- if Is_Discriminant (Lo_Expr) then
- Lo_Expr := Get_Discr_Value (Lo_Expr);
- end if;
+ begin
+ if Is_Record_Type (Typ) then
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Comes_From_Source (Comp) then
+ if Present (Expression (Parent (Comp)))
+ and then Is_Entity_Name (Expression (Parent (Comp)))
+ and then Entity (Expression (Parent (Comp))) = Prev
+ then
+ Error_Msg_Sloc := Sloc (Parent (Comp));
+ Error_Msg_NE
+ ("illegal circularity with declaration for & #",
+ N, Comp);
+ return;
- if Is_Discriminant (Hi_Expr) then
- Hi_Expr := Get_Discr_Value (Hi_Expr);
+ elsif Is_Record_Type (Etype (Comp)) then
+ Check_Recursive_Declaration (Etype (Comp));
+ end if;
end if;
- Range_Node :=
- Make_Range
- (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
-
- Append (Range_Node, To => Constr_List);
-
- Next_Index (Old_Index);
+ Next_Component (Comp);
end loop;
-
- return Build_Subtype (Old_Type, Constr_List);
-
- else
- return Old_Type;
end if;
- end Build_Constrained_Array_Type;
+ end Check_Recursive_Declaration;
- ------------------------------------------
- -- Build_Constrained_Discriminated_Type --
- ------------------------------------------
+ -- Start of processing for Constant_Redeclaration
- function Build_Constrained_Discriminated_Type
- (Old_Type : Entity_Id) return Entity_Id
- is
- Expr : Node_Id;
- Constr_List : List_Id;
- Old_Constraint : Elmt_Id;
-
- Need_To_Create_Itype : Boolean := False;
+ begin
+ if Nkind (Parent (Prev)) = N_Object_Declaration then
+ if Nkind (Object_Definition
+ (Parent (Prev))) = N_Subtype_Indication
+ then
+ -- Find type of new declaration. The constraints of the two
+ -- views must match statically, but there is no point in
+ -- creating an itype for the full view.
- begin
- Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
- while Present (Old_Constraint) loop
- Expr := Node (Old_Constraint);
+ if Nkind (Obj_Def) = N_Subtype_Indication then
+ Find_Type (Subtype_Mark (Obj_Def));
+ New_T := Entity (Subtype_Mark (Obj_Def));
- if Is_Discriminant (Expr) then
- Need_To_Create_Itype := True;
+ else
+ Find_Type (Obj_Def);
+ New_T := Entity (Obj_Def);
end if;
- Next_Elmt (Old_Constraint);
- end loop;
+ T := Etype (Prev);
- if Need_To_Create_Itype then
- Constr_List := New_List;
+ else
+ -- The full view may impose a constraint, even if the partial
+ -- view does not, so construct the subtype.
- Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
- while Present (Old_Constraint) loop
- Expr := Node (Old_Constraint);
+ New_T := Find_Type_Of_Object (Obj_Def, N);
+ T := New_T;
+ end if;
- if Is_Discriminant (Expr) then
- Expr := Get_Discr_Value (Expr);
- end if;
+ else
+ -- Current declaration is illegal, diagnosed below in Enter_Name
- Append (New_Copy_Tree (Expr), To => Constr_List);
+ T := Empty;
+ New_T := Any_Type;
+ end if;
- Next_Elmt (Old_Constraint);
- end loop;
+ -- If previous full declaration or a renaming declaration exists, or if
+ -- a homograph is present, let Enter_Name handle it, either with an
+ -- error or with the removal of an overridden implicit subprogram.
+ -- The previous one is a full declaration if it has an expression
+ -- (which in the case of an aggregate is indicated by the Init flag).
- return Build_Subtype (Old_Type, Constr_List);
+ if Ekind (Prev) /= E_Constant
+ or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration
+ or else Present (Expression (Parent (Prev)))
+ or else Has_Init_Expression (Parent (Prev))
+ or else Present (Full_View (Prev))
+ then
+ Enter_Name (Id);
- else
- return Old_Type;
- end if;
- end Build_Constrained_Discriminated_Type;
+ -- Verify that types of both declarations match, or else that both types
+ -- are anonymous access types whose designated subtypes statically match
+ -- (as allowed in Ada 2005 by AI-385).
- -------------------
- -- Build_Subtype --
- -------------------
+ elsif Base_Type (Etype (Prev)) /= Base_Type (New_T)
+ and then
+ (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type
+ or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type
+ or else Is_Access_Constant (Etype (New_T)) /=
+ Is_Access_Constant (Etype (Prev))
+ or else Can_Never_Be_Null (Etype (New_T)) /=
+ Can_Never_Be_Null (Etype (Prev))
+ or else Null_Exclusion_Present (Parent (Prev)) /=
+ Null_Exclusion_Present (Parent (Id))
+ or else not Subtypes_Statically_Match
+ (Designated_Type (Etype (Prev)),
+ Designated_Type (Etype (New_T))))
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N ("type does not match declaration#", N);
+ Set_Full_View (Prev, Id);
+ Set_Etype (Id, Any_Type);
- function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
- Indic : Node_Id;
- Subtyp_Decl : Node_Id;
- Def_Id : Entity_Id;
- Btyp : Entity_Id := Base_Type (T);
+ elsif
+ Null_Exclusion_Present (Parent (Prev))
+ and then not Null_Exclusion_Present (N)
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N ("null-exclusion does not match declaration#", N);
+ Set_Full_View (Prev, Id);
+ Set_Etype (Id, Any_Type);
- begin
- -- The Related_Node better be here or else we won't be able to
- -- attach new itypes to a node in the tree.
+ -- If so, process the full constant declaration
- pragma Assert (Present (Related_Node));
+ else
+ -- RM 7.4 (6): If the subtype defined by the subtype_indication in
+ -- the deferred declaration is constrained, then the subtype defined
+ -- by the subtype_indication in the full declaration shall match it
+ -- statically.
- -- If the view of the component's type is incomplete or private
- -- with unknown discriminants, then the constraint must be applied
- -- to the full type.
+ Check_Possible_Deferred_Completion
+ (Prev_Id => Prev,
+ Prev_Obj_Def => Object_Definition (Parent (Prev)),
+ Curr_Obj_Def => Obj_Def);
- if Has_Unknown_Discriminants (Btyp)
- and then Present (Underlying_Type (Btyp))
+ Set_Full_View (Prev, Id);
+ Set_Is_Public (Id, Is_Public (Prev));
+ Set_Is_Internal (Id);
+ Append_Entity (Id, Current_Scope);
+
+ -- Check ALIASED present if present before (RM 7.4(7))
+
+ if Is_Aliased (Prev)
+ and then not Aliased_Present (N)
then
- Btyp := Underlying_Type (Btyp);
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N ("ALIASED required (see declaration #)", N);
end if;
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
+ -- Check that placement is in private part and that the incomplete
+ -- declaration appeared in the visible part.
- Def_Id := Create_Itype (Ekind (T), Related_Node);
+ if Ekind (Current_Scope) = E_Package
+ and then not In_Private_Part (Current_Scope)
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N
+ ("full constant for declaration#"
+ & " must be in private part", N);
- Subtyp_Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Indication => Indic);
+ elsif Ekind (Current_Scope) = E_Package
+ and then
+ List_Containing (Parent (Prev)) /=
+ Visible_Declarations (Package_Specification (Current_Scope))
+ then
+ Error_Msg_N
+ ("deferred constant must be declared in visible part",
+ Parent (Prev));
+ end if;
- Set_Parent (Subtyp_Decl, Parent (Related_Node));
+ if Is_Access_Type (T)
+ and then Nkind (Expression (N)) = N_Allocator
+ then
+ Check_Recursive_Declaration (Designated_Type (T));
+ end if;
- -- Itypes must be analyzed with checks off (see package Itypes)
+ -- A deferred constant is a visible entity. If type has invariants,
+ -- verify that the initial value satisfies them.
- Analyze (Subtyp_Decl, Suppress => All_Checks);
+ if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then
+ Insert_After (N,
+ Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N))));
+ end if;
+ end if;
+ end Constant_Redeclaration;
- return Def_Id;
- end Build_Subtype;
+ ----------------------
+ -- Constrain_Access --
+ ----------------------
- ---------------------
- -- Get_Discr_Value --
- ---------------------
+ procedure Constrain_Access
+ (Def_Id : in out Entity_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id)
+ is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ Desig_Type : constant Entity_Id := Designated_Type (T);
+ Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod);
+ Constraint_OK : Boolean := True;
- function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
- D : Entity_Id;
- E : Elmt_Id;
+ begin
+ if Is_Array_Type (Desig_Type) then
+ Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
- begin
- -- The discriminant may be declared for the type, in which case we
- -- find it by iterating over the list of discriminants. If the
- -- discriminant is inherited from a parent type, it appears as the
- -- corresponding discriminant of the current type. This will be the
- -- case when constraining an inherited component whose constraint is
- -- given by a discriminant of the parent.
+ elsif (Is_Record_Type (Desig_Type)
+ or else Is_Incomplete_Or_Private_Type (Desig_Type))
+ and then not Is_Constrained (Desig_Type)
+ then
+ -- ??? The following code is a temporary bypass to ignore a
+ -- discriminant constraint on access type if it is constraining
+ -- the current record. Avoid creating the implicit subtype of the
+ -- record we are currently compiling since right now, we cannot
+ -- handle these. For now, just return the access type itself.
- D := First_Discriminant (Typ);
- E := First_Elmt (Constraints);
+ if Desig_Type = Current_Scope
+ and then No (Def_Id)
+ then
+ Set_Ekind (Desig_Subtype, E_Record_Subtype);
+ Def_Id := Entity (Subtype_Mark (S));
- while Present (D) loop
- if D = Entity (Discrim)
- or else D = CR_Discriminant (Entity (Discrim))
- or else Corresponding_Discriminant (D) = Entity (Discrim)
- then
- return Node (E);
- end if;
+ -- This call added to ensure that the constraint is analyzed
+ -- (needed for a B test). Note that we still return early from
+ -- this procedure to avoid recursive processing. ???
- Next_Discriminant (D);
- Next_Elmt (E);
- end loop;
+ Constrain_Discriminated_Type
+ (Desig_Subtype, S, Related_Nod, For_Access => True);
+ return;
+ end if;
- -- The Corresponding_Discriminant mechanism is incomplete, because
- -- the correspondence between new and old discriminants is not one
- -- to one: one new discriminant can constrain several old ones. In
- -- that case, scan sequentially the stored_constraint, the list of
- -- discriminants of the parents, and the constraints.
+ -- Enforce rule that the constraint is illegal if there is an
+ -- unconstrained view of the designated type. This means that the
+ -- partial view (either a private type declaration or a derivation
+ -- from a private type) has no discriminants. (Defect Report
+ -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001).
- -- Previous code checked for the present of the Stored_Constraint
- -- list for the derived type, but did not use it at all. Should it
- -- be present when the component is a discriminated task type?
+ -- Rule updated for Ada 2005: The private type is said to have
+ -- a constrained partial view, given that objects of the type
+ -- can be declared. Furthermore, the rule applies to all access
+ -- types, unlike the rule concerning default discriminants (see
+ -- RM 3.7.1(7/3))
- if Is_Derived_Type (Typ)
- and then Scope (Entity (Discrim)) = Etype (Typ)
+ if (Ekind (T) = E_General_Access_Type or else Ada_Version >= Ada_2005)
+ and then Has_Private_Declaration (Desig_Type)
+ and then In_Open_Scopes (Scope (Desig_Type))
+ and then Has_Discriminants (Desig_Type)
then
- D := First_Discriminant (Etype (Typ));
- E := First_Elmt (Constraints);
- while Present (D) loop
- if D = Entity (Discrim) then
- return Node (E);
- end if;
-
- Next_Discriminant (D);
- Next_Elmt (E);
- end loop;
- end if;
-
- -- Something is wrong if we did not find the value
-
- raise Program_Error;
- end Get_Discr_Value;
-
- ---------------------
- -- Is_Discriminant --
- ---------------------
-
- function Is_Discriminant (Expr : Node_Id) return Boolean is
- Discrim_Scope : Entity_Id;
-
- begin
- if Denotes_Discriminant (Expr) then
- Discrim_Scope := Scope (Entity (Expr));
-
- -- Either we have a reference to one of Typ's discriminants,
-
- pragma Assert (Discrim_Scope = Typ
-
- -- or to the discriminants of the parent type, in the case
- -- of a derivation of a tagged type with variants.
+ declare
+ Pack : constant Node_Id :=
+ Unit_Declaration_Node (Scope (Desig_Type));
+ Decls : List_Id;
+ Decl : Node_Id;
- or else Discrim_Scope = Etype (Typ)
- or else Full_View (Discrim_Scope) = Etype (Typ)
+ begin
+ if Nkind (Pack) = N_Package_Declaration then
+ Decls := Visible_Declarations (Specification (Pack));
+ Decl := First (Decls);
+ while Present (Decl) loop
+ if (Nkind (Decl) = N_Private_Type_Declaration
+ and then Chars (Defining_Identifier (Decl)) =
+ Chars (Desig_Type))
- -- or same as above for the case where the discriminants
- -- were declared in Typ's private view.
+ or else
+ (Nkind (Decl) = N_Full_Type_Declaration
+ and then
+ Chars (Defining_Identifier (Decl)) =
+ Chars (Desig_Type)
+ and then Is_Derived_Type (Desig_Type)
+ and then
+ Has_Private_Declaration (Etype (Desig_Type)))
+ then
+ if No (Discriminant_Specifications (Decl)) then
+ Error_Msg_N
+ ("cannot constrain access type if designated "
+ & "type has constrained partial view", S);
+ end if;
- or else (Is_Private_Type (Discrim_Scope)
- and then Chars (Discrim_Scope) = Chars (Typ))
+ exit;
+ end if;
- -- or else we are deriving from the full view and the
- -- discriminant is declared in the private entity.
+ Next (Decl);
+ end loop;
+ end if;
+ end;
+ end if;
- or else (Is_Private_Type (Typ)
- and then Chars (Discrim_Scope) = Chars (Typ))
+ Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
+ For_Access => True);
- -- Or we are constrained the corresponding record of a
- -- synchronized type that completes a private declaration.
+ elsif (Is_Task_Type (Desig_Type) or else Is_Protected_Type (Desig_Type))
+ and then not Is_Constrained (Desig_Type)
+ then
+ Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
- or else (Is_Concurrent_Record_Type (Typ)
- and then
- Corresponding_Concurrent_Type (Typ) = Discrim_Scope)
+ else
+ Error_Msg_N ("invalid constraint on access type", S);
+ Desig_Subtype := Desig_Type; -- Ignore invalid constraint
+ Constraint_OK := False;
+ end if;
- -- or we have a class-wide type, in which case make sure the
- -- discriminant found belongs to the root type.
+ if No (Def_Id) then
+ Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
+ else
+ Set_Ekind (Def_Id, E_Access_Subtype);
+ end if;
- or else (Is_Class_Wide_Type (Typ)
- and then Etype (Typ) = Discrim_Scope));
+ if Constraint_OK then
+ Set_Etype (Def_Id, Base_Type (T));
- return True;
+ if Is_Private_Type (Desig_Type) then
+ Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
end if;
+ else
+ Set_Etype (Def_Id, Any_Type);
+ end if;
- -- In all other cases we have something wrong
-
- return False;
- end Is_Discriminant;
+ Set_Size_Info (Def_Id, T);
+ Set_Is_Constrained (Def_Id, Constraint_OK);
+ Set_Directly_Designated_Type (Def_Id, Desig_Subtype);
+ Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
+ Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T));
- -- Start of processing for Constrain_Component_Type
+ Conditional_Delay (Def_Id, T);
- begin
- if Nkind (Parent (Comp)) = N_Component_Declaration
- and then Comes_From_Source (Parent (Comp))
- and then Comes_From_Source
- (Subtype_Indication (Component_Definition (Parent (Comp))))
- and then
- Is_Entity_Name
- (Subtype_Indication (Component_Definition (Parent (Comp))))
- then
- return Compon_Type;
+ -- AI-363 : Subtypes of general access types whose designated types have
+ -- default discriminants are disallowed. In instances, the rule has to
+ -- be checked against the actual, of which T is the subtype. In a
+ -- generic body, the rule is checked assuming that the actual type has
+ -- defaulted discriminants.
- elsif Is_Array_Type (Compon_Type) then
- return Build_Constrained_Array_Type (Compon_Type);
+ if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then
+ if Ekind (Base_Type (T)) = E_General_Access_Type
+ and then Has_Defaulted_Discriminants (Desig_Type)
+ then
+ if Ada_Version < Ada_2005 then
+ Error_Msg_N
+ ("access subtype of general access type would not " &
+ "be allowed in Ada 2005?y?", S);
+ else
+ Error_Msg_N
+ ("access subtype of general access type not allowed", S);
+ end if;
- elsif Has_Discriminants (Compon_Type) then
- return Build_Constrained_Discriminated_Type (Compon_Type);
+ Error_Msg_N ("\discriminants have defaults", S);
- elsif Is_Access_Type (Compon_Type) then
- return Build_Constrained_Access_Type (Compon_Type);
+ elsif Is_Access_Type (T)
+ and then Is_Generic_Type (Desig_Type)
+ and then Has_Discriminants (Desig_Type)
+ and then In_Package_Body (Current_Scope)
+ then
+ if Ada_Version < Ada_2005 then
+ Error_Msg_N
+ ("access subtype would not be allowed in generic body "
+ & "in Ada 2005?y?", S);
+ else
+ Error_Msg_N
+ ("access subtype not allowed in generic body", S);
+ end if;
- else
- return Compon_Type;
+ Error_Msg_N
+ ("\designated type is a discriminated formal", S);
+ end if;
end if;
- end Constrain_Component_Type;
-
- --------------------------
- -- Constrain_Concurrent --
- --------------------------
+ end Constrain_Access;
- -- For concurrent types, the associated record value type carries the same
- -- discriminants, so when we constrain a concurrent type, we must constrain
- -- the corresponding record type as well.
+ ---------------------
+ -- Constrain_Array --
+ ---------------------
- procedure Constrain_Concurrent
+ procedure Constrain_Array
(Def_Id : in out Entity_Id;
SI : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id;
Suffix : Character)
is
- -- Retrieve Base_Type to ensure getting to the concurrent type in the
- -- case of a private subtype (needed when only doing semantic analysis).
-
- T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI)));
- T_Val : Entity_Id;
+ C : constant Node_Id := Constraint (SI);
+ Number_Of_Constraints : Nat := 0;
+ Index : Node_Id;
+ S, T : Entity_Id;
+ Constraint_OK : Boolean := True;
begin
- if Is_Access_Type (T_Ent) then
- T_Ent := Designated_Type (T_Ent);
+ T := Entity (Subtype_Mark (SI));
+
+ if Is_Access_Type (T) then
+ T := Designated_Type (T);
end if;
- T_Val := Corresponding_Record_Type (T_Ent);
+ -- If an index constraint follows a subtype mark in a subtype indication
+ -- then the type or subtype denoted by the subtype mark must not already
+ -- impose an index constraint. The subtype mark must denote either an
+ -- unconstrained array type or an access type whose designated type
+ -- is such an array type... (RM 3.6.1)
- if Present (T_Val) then
+ if Is_Constrained (T) then
+ Error_Msg_N ("array type is already constrained", Subtype_Mark (SI));
+ Constraint_OK := False;
- if No (Def_Id) then
- Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
- end if;
+ else
+ S := First (Constraints (C));
+ while Present (S) loop
+ Number_Of_Constraints := Number_Of_Constraints + 1;
+ Next (S);
+ end loop;
- Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+ -- In either case, the index constraint must provide a discrete
+ -- range for each index of the array type and the type of each
+ -- discrete range must be the same as that of the corresponding
+ -- index. (RM 3.6.1)
- Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
- Set_Corresponding_Record_Type (Def_Id,
- Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod));
+ if Number_Of_Constraints /= Number_Dimensions (T) then
+ Error_Msg_NE ("incorrect number of index constraints for }", C, T);
+ Constraint_OK := False;
- else
- -- If there is no associated record, expansion is disabled and this
- -- is a generic context. Create a subtype in any case, so that
- -- semantic analysis can proceed.
+ else
+ S := First (Constraints (C));
+ Index := First_Index (T);
+ Analyze (Index);
- if No (Def_Id) then
- Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
- end if;
+ -- Apply constraints to each index type
- Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
- end if;
- end Constrain_Concurrent;
+ for J in 1 .. Number_Of_Constraints loop
+ Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
+ Next (Index);
+ Next (S);
+ end loop;
- ------------------------------------
- -- Constrain_Corresponding_Record --
- ------------------------------------
+ end if;
+ end if;
- function Constrain_Corresponding_Record
- (Prot_Subt : Entity_Id;
- Corr_Rec : Entity_Id;
- Related_Nod : Node_Id) return Entity_Id
- is
- T_Sub : constant Entity_Id :=
- Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C');
+ if No (Def_Id) then
+ Def_Id :=
+ Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
+ Set_Parent (Def_Id, Related_Nod);
- begin
- Set_Etype (T_Sub, Corr_Rec);
- Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
- Set_Is_Constrained (T_Sub, True);
- Set_First_Entity (T_Sub, First_Entity (Corr_Rec));
- Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec));
+ else
+ Set_Ekind (Def_Id, E_Array_Subtype);
+ end if;
- if Has_Discriminants (Prot_Subt) then -- False only if errors.
- Set_Discriminant_Constraint
- (T_Sub, Discriminant_Constraint (Prot_Subt));
- Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub);
- Create_Constrained_Components
- (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Etype (Def_Id, Base_Type (T));
+
+ if Constraint_OK then
+ Set_First_Index (Def_Id, First (Constraints (C)));
+ else
+ Set_First_Index (Def_Id, First_Index (T));
end if;
- Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub));
+ Set_Is_Constrained (Def_Id, True);
+ Set_Is_Aliased (Def_Id, Is_Aliased (T));
+ Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
- if Ekind (Scope (Prot_Subt)) /= E_Record_Type then
- Conditional_Delay (T_Sub, Corr_Rec);
+ Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
+ Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
- else
- -- This is a component subtype: it will be frozen in the context of
- -- the enclosing record's init_proc, so that discriminant references
- -- are resolved to discriminals. (Note: we used to skip freezing
- -- altogether in that case, which caused errors downstream for
- -- components of a bit packed array type).
+ -- A subtype does not inherit the Packed_Array_Impl_Type of is parent.
+ -- We need to initialize the attribute because if Def_Id is previously
+ -- analyzed through a limited_with clause, it will have the attributes
+ -- of an incomplete type, one of which is an Elist that overlaps the
+ -- Packed_Array_Impl_Type field.
- Set_Has_Delayed_Freeze (T_Sub);
- end if;
+ Set_Packed_Array_Impl_Type (Def_Id, Empty);
- return T_Sub;
- end Constrain_Corresponding_Record;
+ -- Build a freeze node if parent still needs one. Also make sure that
+ -- the Depends_On_Private status is set because the subtype will need
+ -- reprocessing at the time the base type does, and also we must set a
+ -- conditional delay.
- -----------------------
- -- Constrain_Decimal --
- -----------------------
+ Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
+ Conditional_Delay (Def_Id, T);
+ end Constrain_Array;
- procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is
- T : constant Entity_Id := Entity (Subtype_Mark (S));
- C : constant Node_Id := Constraint (S);
- Loc : constant Source_Ptr := Sloc (C);
- Range_Expr : Node_Id;
- Digits_Expr : Node_Id;
- Digits_Val : Uint;
- Bound_Val : Ureal;
+ ------------------------------
+ -- Constrain_Component_Type --
+ ------------------------------
- begin
- Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
+ function Constrain_Component_Type
+ (Comp : Entity_Id;
+ Constrained_Typ : Entity_Id;
+ Related_Node : Node_Id;
+ Typ : Entity_Id;
+ Constraints : Elist_Id) return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Constrained_Typ);
+ Compon_Type : constant Entity_Id := Etype (Comp);
- if Nkind (C) = N_Range_Constraint then
- Range_Expr := Range_Expression (C);
- Digits_Val := Digits_Value (T);
+ function Build_Constrained_Array_Type
+ (Old_Type : Entity_Id) return Entity_Id;
+ -- If Old_Type is an array type, one of whose indexes is constrained
+ -- by a discriminant, build an Itype whose constraint replaces the
+ -- discriminant with its value in the constraint.
- else
- pragma Assert (Nkind (C) = N_Digits_Constraint);
+ function Build_Constrained_Discriminated_Type
+ (Old_Type : Entity_Id) return Entity_Id;
+ -- Ditto for record components
- Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
+ function Build_Constrained_Access_Type
+ (Old_Type : Entity_Id) return Entity_Id;
+ -- Ditto for access types. Makes use of previous two functions, to
+ -- constrain designated type.
- Digits_Expr := Digits_Expression (C);
- Analyze_And_Resolve (Digits_Expr, Any_Integer);
+ function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
+ -- T is an array or discriminated type, C is a list of constraints
+ -- that apply to T. This routine builds the constrained subtype.
- Check_Digits_Expression (Digits_Expr);
- Digits_Val := Expr_Value (Digits_Expr);
+ function Is_Discriminant (Expr : Node_Id) return Boolean;
+ -- Returns True if Expr is a discriminant
- if Digits_Val > Digits_Value (T) then
- Error_Msg_N
- ("digits expression is incompatible with subtype", C);
- Digits_Val := Digits_Value (T);
- end if;
+ function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
+ -- Find the value of discriminant Discrim in Constraint
- if Present (Range_Constraint (C)) then
- Range_Expr := Range_Expression (Range_Constraint (C));
- else
- Range_Expr := Empty;
- end if;
- end if;
+ -----------------------------------
+ -- Build_Constrained_Access_Type --
+ -----------------------------------
- Set_Etype (Def_Id, Base_Type (T));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- Set_Delta_Value (Def_Id, Delta_Value (T));
- Set_Scale_Value (Def_Id, Scale_Value (T));
- Set_Small_Value (Def_Id, Small_Value (T));
- Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T));
- Set_Digits_Value (Def_Id, Digits_Val);
+ function Build_Constrained_Access_Type
+ (Old_Type : Entity_Id) return Entity_Id
+ is
+ Desig_Type : constant Entity_Id := Designated_Type (Old_Type);
+ Itype : Entity_Id;
+ Desig_Subtype : Entity_Id;
+ Scop : Entity_Id;
- -- Manufacture range from given digits value if no range present
+ begin
+ -- if the original access type was not embedded in the enclosing
+ -- type definition, there is no need to produce a new access
+ -- subtype. In fact every access type with an explicit constraint
+ -- generates an itype whose scope is the enclosing record.
- if No (Range_Expr) then
- Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T);
- Range_Expr :=
- Make_Range (Loc,
- Low_Bound =>
- Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))),
- High_Bound =>
- Convert_To (T, Make_Real_Literal (Loc, Bound_Val)));
- end if;
+ if not Is_Type (Scope (Old_Type)) then
+ return Old_Type;
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T);
- Set_Discrete_RM_Size (Def_Id);
+ elsif Is_Array_Type (Desig_Type) then
+ Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
- -- Unconditionally delay the freeze, since we cannot set size
- -- information in all cases correctly until the freeze point.
+ elsif Has_Discriminants (Desig_Type) then
- Set_Has_Delayed_Freeze (Def_Id);
- end Constrain_Decimal;
+ -- This may be an access type to an enclosing record type for
+ -- which we are constructing the constrained components. Return
+ -- the enclosing record subtype. This is not always correct,
+ -- but avoids infinite recursion. ???
- ----------------------------------
- -- Constrain_Discriminated_Type --
- ----------------------------------
+ Desig_Subtype := Any_Type;
- procedure Constrain_Discriminated_Type
- (Def_Id : Entity_Id;
- S : Node_Id;
- Related_Nod : Node_Id;
- For_Access : Boolean := False)
- is
- E : constant Entity_Id := Entity (Subtype_Mark (S));
- T : Entity_Id;
- C : Node_Id;
- Elist : Elist_Id := New_Elmt_List;
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Scop := Scope_Stack.Table (J).Entity;
- procedure Fixup_Bad_Constraint;
- -- This is called after finding a bad constraint, and after having
- -- posted an appropriate error message. The mission is to leave the
- -- entity T in as reasonable state as possible.
+ if Is_Type (Scop)
+ and then Base_Type (Scop) = Base_Type (Desig_Type)
+ then
+ Desig_Subtype := Scop;
+ end if;
- --------------------------
- -- Fixup_Bad_Constraint --
- --------------------------
+ exit when not Is_Type (Scop);
+ end loop;
- procedure Fixup_Bad_Constraint is
- begin
- -- Set a reasonable Ekind for the entity. For an incomplete type,
- -- we can't do much, but for other types, we can set the proper
- -- corresponding subtype kind.
+ if Desig_Subtype = Any_Type then
+ Desig_Subtype :=
+ Build_Constrained_Discriminated_Type (Desig_Type);
+ end if;
- if Ekind (T) = E_Incomplete_Type then
- Set_Ekind (Def_Id, Ekind (T));
else
- Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+ return Old_Type;
end if;
- -- Set Etype to the known type, to reduce chances of cascaded errors
+ if Desig_Subtype /= Desig_Type then
- Set_Etype (Def_Id, E);
- Set_Error_Posted (Def_Id);
- end Fixup_Bad_Constraint;
+ -- The Related_Node better be here or else we won't be able
+ -- to attach new itypes to a node in the tree.
- -- Start of processing for Constrain_Discriminated_Type
+ pragma Assert (Present (Related_Node));
- begin
- C := Constraint (S);
+ Itype := Create_Itype (E_Access_Subtype, Related_Node);
- -- A discriminant constraint is only allowed in a subtype indication,
- -- after a subtype mark. This subtype mark must denote either a type
- -- with discriminants, or an access type whose designated type is a
- -- type with discriminants. A discriminant constraint specifies the
- -- values of these discriminants (RM 3.7.2(5)).
+ Set_Etype (Itype, Base_Type (Old_Type));
+ Set_Size_Info (Itype, (Old_Type));
+ Set_Directly_Designated_Type (Itype, Desig_Subtype);
+ Set_Depends_On_Private (Itype, Has_Private_Component
+ (Old_Type));
+ Set_Is_Access_Constant (Itype, Is_Access_Constant
+ (Old_Type));
- T := Base_Type (Entity (Subtype_Mark (S)));
+ -- The new itype needs freezing when it depends on a not frozen
+ -- type and the enclosing subtype needs freezing.
- if Is_Access_Type (T) then
- T := Designated_Type (T);
- end if;
+ if Has_Delayed_Freeze (Constrained_Typ)
+ and then not Is_Frozen (Constrained_Typ)
+ then
+ Conditional_Delay (Itype, Base_Type (Old_Type));
+ end if;
- -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
- -- Avoid generating an error for access-to-incomplete subtypes.
-
- if Ada_Version >= Ada_2005
- and then Ekind (T) = E_Incomplete_Type
- and then Nkind (Parent (S)) = N_Subtype_Declaration
- and then not Is_Itype (Def_Id)
- then
- -- A little sanity check, emit an error message if the type
- -- has discriminants to begin with. Type T may be a regular
- -- incomplete type or imported via a limited with clause.
+ return Itype;
- if Has_Discriminants (T)
- or else (From_Limited_With (T)
- and then Present (Non_Limited_View (T))
- and then Nkind (Parent (Non_Limited_View (T))) =
- N_Full_Type_Declaration
- and then Present (Discriminant_Specifications
- (Parent (Non_Limited_View (T)))))
- then
- Error_Msg_N
- ("(Ada 2005) incomplete subtype may not be constrained", C);
else
- Error_Msg_N ("invalid constraint: type has no discriminant", C);
+ return Old_Type;
end if;
+ end Build_Constrained_Access_Type;
- Fixup_Bad_Constraint;
- return;
+ ----------------------------------
+ -- Build_Constrained_Array_Type --
+ ----------------------------------
- -- Check that the type has visible discriminants. The type may be
- -- a private type with unknown discriminants whose full view has
- -- discriminants which are invisible.
+ function Build_Constrained_Array_Type
+ (Old_Type : Entity_Id) return Entity_Id
+ is
+ Lo_Expr : Node_Id;
+ Hi_Expr : Node_Id;
+ Old_Index : Node_Id;
+ Range_Node : Node_Id;
+ Constr_List : List_Id;
- elsif not Has_Discriminants (T)
- or else
- (Has_Unknown_Discriminants (T)
- and then Is_Private_Type (T))
- then
- Error_Msg_N ("invalid constraint: type has no discriminant", C);
- Fixup_Bad_Constraint;
- return;
+ Need_To_Create_Itype : Boolean := False;
- elsif Is_Constrained (E)
- or else (Ekind (E) = E_Class_Wide_Subtype
- and then Present (Discriminant_Constraint (E)))
- then
- Error_Msg_N ("type is already constrained", Subtype_Mark (S));
- Fixup_Bad_Constraint;
- return;
- end if;
+ begin
+ Old_Index := First_Index (Old_Type);
+ while Present (Old_Index) loop
+ Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
- -- T may be an unconstrained subtype (e.g. a generic actual).
- -- Constraint applies to the base type.
+ if Is_Discriminant (Lo_Expr)
+ or else Is_Discriminant (Hi_Expr)
+ then
+ Need_To_Create_Itype := True;
+ end if;
- T := Base_Type (T);
+ Next_Index (Old_Index);
+ end loop;
- Elist := Build_Discriminant_Constraints (T, S);
+ if Need_To_Create_Itype then
+ Constr_List := New_List;
- -- If the list returned was empty we had an error in building the
- -- discriminant constraint. We have also already signalled an error
- -- in the incomplete type case
+ Old_Index := First_Index (Old_Type);
+ while Present (Old_Index) loop
+ Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
- if Is_Empty_Elmt_List (Elist) then
- Fixup_Bad_Constraint;
- return;
- end if;
+ if Is_Discriminant (Lo_Expr) then
+ Lo_Expr := Get_Discr_Value (Lo_Expr);
+ end if;
- Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
- end Constrain_Discriminated_Type;
+ if Is_Discriminant (Hi_Expr) then
+ Hi_Expr := Get_Discr_Value (Hi_Expr);
+ end if;
- ---------------------------
- -- Constrain_Enumeration --
- ---------------------------
+ Range_Node :=
+ Make_Range
+ (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
- procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is
- T : constant Entity_Id := Entity (Subtype_Mark (S));
- C : constant Node_Id := Constraint (S);
+ Append (Range_Node, To => Constr_List);
- begin
- Set_Ekind (Def_Id, E_Enumeration_Subtype);
+ Next_Index (Old_Index);
+ end loop;
- Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
+ return Build_Subtype (Old_Type, Constr_List);
- Set_Etype (Def_Id, Base_Type (T));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+ else
+ return Old_Type;
+ end if;
+ end Build_Constrained_Array_Type;
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
+ ------------------------------------------
+ -- Build_Constrained_Discriminated_Type --
+ ------------------------------------------
- Set_Discrete_RM_Size (Def_Id);
- end Constrain_Enumeration;
+ function Build_Constrained_Discriminated_Type
+ (Old_Type : Entity_Id) return Entity_Id
+ is
+ Expr : Node_Id;
+ Constr_List : List_Id;
+ Old_Constraint : Elmt_Id;
- ----------------------
- -- Constrain_Float --
- ----------------------
+ Need_To_Create_Itype : Boolean := False;
- procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is
- T : constant Entity_Id := Entity (Subtype_Mark (S));
- C : Node_Id;
- D : Node_Id;
- Rais : Node_Id;
+ begin
+ Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
+ while Present (Old_Constraint) loop
+ Expr := Node (Old_Constraint);
- begin
- Set_Ekind (Def_Id, E_Floating_Point_Subtype);
+ if Is_Discriminant (Expr) then
+ Need_To_Create_Itype := True;
+ end if;
- Set_Etype (Def_Id, Base_Type (T));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Next_Elmt (Old_Constraint);
+ end loop;
- -- Process the constraint
+ if Need_To_Create_Itype then
+ Constr_List := New_List;
- C := Constraint (S);
+ Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
+ while Present (Old_Constraint) loop
+ Expr := Node (Old_Constraint);
- -- Digits constraint present
+ if Is_Discriminant (Expr) then
+ Expr := Get_Discr_Value (Expr);
+ end if;
- if Nkind (C) = N_Digits_Constraint then
+ Append (New_Copy_Tree (Expr), To => Constr_List);
- Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
- Check_Restriction (No_Obsolescent_Features, C);
+ Next_Elmt (Old_Constraint);
+ end loop;
- if Warn_On_Obsolescent_Feature then
- Error_Msg_N
- ("subtype digits constraint is an " &
- "obsolescent feature (RM J.3(8))?j?", C);
+ return Build_Subtype (Old_Type, Constr_List);
+
+ else
+ return Old_Type;
end if;
+ end Build_Constrained_Discriminated_Type;
- D := Digits_Expression (C);
- Analyze_And_Resolve (D, Any_Integer);
- Check_Digits_Expression (D);
- Set_Digits_Value (Def_Id, Expr_Value (D));
+ -------------------
+ -- Build_Subtype --
+ -------------------
- -- Check that digits value is in range. Obviously we can do this
- -- at compile time, but it is strictly a runtime check, and of
- -- course there is an ACVC test that checks this.
+ function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
+ Indic : Node_Id;
+ Subtyp_Decl : Node_Id;
+ Def_Id : Entity_Id;
+ Btyp : Entity_Id := Base_Type (T);
- if Digits_Value (Def_Id) > Digits_Value (T) then
- Error_Msg_Uint_1 := Digits_Value (T);
- Error_Msg_N ("??digits value is too large, maximum is ^", D);
- Rais :=
- Make_Raise_Constraint_Error (Sloc (D),
- Reason => CE_Range_Check_Failed);
- Insert_Action (Declaration_Node (Def_Id), Rais);
- end if;
+ begin
+ -- The Related_Node better be here or else we won't be able to
+ -- attach new itypes to a node in the tree.
- C := Range_Constraint (C);
+ pragma Assert (Present (Related_Node));
- -- No digits constraint present
+ -- If the view of the component's type is incomplete or private
+ -- with unknown discriminants, then the constraint must be applied
+ -- to the full type.
- else
- Set_Digits_Value (Def_Id, Digits_Value (T));
- end if;
+ if Has_Unknown_Discriminants (Btyp)
+ and then Present (Underlying_Type (Btyp))
+ then
+ Btyp := Underlying_Type (Btyp);
+ end if;
- -- Range constraint present
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
- if Nkind (C) = N_Range_Constraint then
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
+ Def_Id := Create_Itype (Ekind (T), Related_Node);
- -- No range constraint present
+ Subtyp_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication => Indic);
- else
- pragma Assert (No (C));
- Set_Scalar_Range (Def_Id, Scalar_Range (T));
- end if;
+ Set_Parent (Subtyp_Decl, Parent (Related_Node));
- Set_Is_Constrained (Def_Id);
- end Constrain_Float;
+ -- Itypes must be analyzed with checks off (see package Itypes)
- ---------------------
- -- Constrain_Index --
- ---------------------
+ Analyze (Subtyp_Decl, Suppress => All_Checks);
- procedure Constrain_Index
- (Index : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id;
- Suffix : Character;
- Suffix_Index : Nat)
- is
- Def_Id : Entity_Id;
- R : Node_Id := Empty;
- T : constant Entity_Id := Etype (Index);
+ return Def_Id;
+ end Build_Subtype;
- begin
- if Nkind (S) = N_Range
- or else
- (Nkind (S) = N_Attribute_Reference
- and then Attribute_Name (S) = Name_Range)
- then
- -- A Range attribute will be transformed into N_Range by Resolve
+ ---------------------
+ -- Get_Discr_Value --
+ ---------------------
- Analyze (S);
- Set_Etype (S, T);
- R := S;
+ function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
+ D : Entity_Id;
+ E : Elmt_Id;
- Process_Range_Expr_In_Decl (R, T);
+ begin
+ -- The discriminant may be declared for the type, in which case we
+ -- find it by iterating over the list of discriminants. If the
+ -- discriminant is inherited from a parent type, it appears as the
+ -- corresponding discriminant of the current type. This will be the
+ -- case when constraining an inherited component whose constraint is
+ -- given by a discriminant of the parent.
- if not Error_Posted (S)
- and then
- (Nkind (S) /= N_Range
- or else not Covers (T, (Etype (Low_Bound (S))))
- or else not Covers (T, (Etype (High_Bound (S)))))
- then
- if Base_Type (T) /= Any_Type
- and then Etype (Low_Bound (S)) /= Any_Type
- and then Etype (High_Bound (S)) /= Any_Type
+ D := First_Discriminant (Typ);
+ E := First_Elmt (Constraints);
+
+ while Present (D) loop
+ if D = Entity (Discrim)
+ or else D = CR_Discriminant (Entity (Discrim))
+ or else Corresponding_Discriminant (D) = Entity (Discrim)
then
- Error_Msg_N ("range expected", S);
+ return Node (E);
end if;
- end if;
-
- elsif Nkind (S) = N_Subtype_Indication then
- -- The parser has verified that this is a discrete indication
-
- Resolve_Discrete_Subtype_Indication (S, T);
- Bad_Predicated_Subtype_Use
- ("subtype& has predicate, not allowed in index constraint",
- S, Entity (Subtype_Mark (S)));
+ Next_Discriminant (D);
+ Next_Elmt (E);
+ end loop;
- R := Range_Expression (Constraint (S));
+ -- The Corresponding_Discriminant mechanism is incomplete, because
+ -- the correspondence between new and old discriminants is not one
+ -- to one: one new discriminant can constrain several old ones. In
+ -- that case, scan sequentially the stored_constraint, the list of
+ -- discriminants of the parents, and the constraints.
- -- Capture values of bounds and generate temporaries for them if
- -- needed, since checks may cause duplication of the expressions
- -- which must not be reevaluated.
+ -- Previous code checked for the present of the Stored_Constraint
+ -- list for the derived type, but did not use it at all. Should it
+ -- be present when the component is a discriminated task type?
- -- The forced evaluation removes side effects from expressions, which
- -- should occur also in GNATprove mode. Otherwise, we end up with
- -- unexpected insertions of actions at places where this is not
- -- supposed to occur, e.g. on default parameters of a call.
+ if Is_Derived_Type (Typ)
+ and then Scope (Entity (Discrim)) = Etype (Typ)
+ then
+ D := First_Discriminant (Etype (Typ));
+ E := First_Elmt (Constraints);
+ while Present (D) loop
+ if D = Entity (Discrim) then
+ return Node (E);
+ end if;
- if Expander_Active or GNATprove_Mode then
- Force_Evaluation (Low_Bound (R));
- Force_Evaluation (High_Bound (R));
+ Next_Discriminant (D);
+ Next_Elmt (E);
+ end loop;
end if;
- elsif Nkind (S) = N_Discriminant_Association then
+ -- Something is wrong if we did not find the value
- -- Syntactically valid in subtype indication
+ raise Program_Error;
+ end Get_Discr_Value;
- Error_Msg_N ("invalid index constraint", S);
- Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
- return;
+ ---------------------
+ -- Is_Discriminant --
+ ---------------------
- -- Subtype_Mark case, no anonymous subtypes to construct
+ function Is_Discriminant (Expr : Node_Id) return Boolean is
+ Discrim_Scope : Entity_Id;
- else
- Analyze (S);
+ begin
+ if Denotes_Discriminant (Expr) then
+ Discrim_Scope := Scope (Entity (Expr));
- if Is_Entity_Name (S) then
- if not Is_Type (Entity (S)) then
- Error_Msg_N ("expect subtype mark for index constraint", S);
+ -- Either we have a reference to one of Typ's discriminants,
- elsif Base_Type (Entity (S)) /= Base_Type (T) then
- Wrong_Type (S, Base_Type (T));
+ pragma Assert (Discrim_Scope = Typ
- -- Check error of subtype with predicate in index constraint
+ -- or to the discriminants of the parent type, in the case
+ -- of a derivation of a tagged type with variants.
- else
- Bad_Predicated_Subtype_Use
- ("subtype& has predicate, not allowed in index constraint",
- S, Entity (S));
- end if;
+ or else Discrim_Scope = Etype (Typ)
+ or else Full_View (Discrim_Scope) = Etype (Typ)
- return;
+ -- or same as above for the case where the discriminants
+ -- were declared in Typ's private view.
- else
- Error_Msg_N ("invalid index constraint", S);
- Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
- return;
- end if;
- end if;
+ or else (Is_Private_Type (Discrim_Scope)
+ and then Chars (Discrim_Scope) = Chars (Typ))
- Def_Id :=
- Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
+ -- or else we are deriving from the full view and the
+ -- discriminant is declared in the private entity.
- Set_Etype (Def_Id, Base_Type (T));
+ or else (Is_Private_Type (Typ)
+ and then Chars (Discrim_Scope) = Chars (Typ))
- if Is_Modular_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+ -- Or we are constrained the corresponding record of a
+ -- synchronized type that completes a private declaration.
- elsif Is_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+ or else (Is_Concurrent_Record_Type (Typ)
+ and then
+ Corresponding_Concurrent_Type (Typ) = Discrim_Scope)
- else
- Set_Ekind (Def_Id, E_Enumeration_Subtype);
- Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
- Set_First_Literal (Def_Id, First_Literal (T));
- end if;
+ -- or we have a class-wide type, in which case make sure the
+ -- discriminant found belongs to the root type.
- Set_Size_Info (Def_Id, (T));
- Set_RM_Size (Def_Id, RM_Size (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ or else (Is_Class_Wide_Type (Typ)
+ and then Etype (Typ) = Discrim_Scope));
- Set_Scalar_Range (Def_Id, R);
+ return True;
+ end if;
- Set_Etype (S, Def_Id);
- Set_Discrete_RM_Size (Def_Id);
- end Constrain_Index;
+ -- In all other cases we have something wrong
- -----------------------
- -- Constrain_Integer --
- -----------------------
+ return False;
+ end Is_Discriminant;
- procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is
- T : constant Entity_Id := Entity (Subtype_Mark (S));
- C : constant Node_Id := Constraint (S);
+ -- Start of processing for Constrain_Component_Type
begin
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
+ if Nkind (Parent (Comp)) = N_Component_Declaration
+ and then Comes_From_Source (Parent (Comp))
+ and then Comes_From_Source
+ (Subtype_Indication (Component_Definition (Parent (Comp))))
+ and then
+ Is_Entity_Name
+ (Subtype_Indication (Component_Definition (Parent (Comp))))
+ then
+ return Compon_Type;
+
+ elsif Is_Array_Type (Compon_Type) then
+ return Build_Constrained_Array_Type (Compon_Type);
+
+ elsif Has_Discriminants (Compon_Type) then
+ return Build_Constrained_Discriminated_Type (Compon_Type);
+
+ elsif Is_Access_Type (Compon_Type) then
+ return Build_Constrained_Access_Type (Compon_Type);
- if Is_Modular_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
else
- Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+ return Compon_Type;
end if;
+ end Constrain_Component_Type;
- Set_Etype (Def_Id, Base_Type (T));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- Set_Discrete_RM_Size (Def_Id);
- end Constrain_Integer;
+ --------------------------
+ -- Constrain_Concurrent --
+ --------------------------
- ------------------------------
- -- Constrain_Ordinary_Fixed --
- ------------------------------
+ -- For concurrent types, the associated record value type carries the same
+ -- discriminants, so when we constrain a concurrent type, we must constrain
+ -- the corresponding record type as well.
- procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is
- T : constant Entity_Id := Entity (Subtype_Mark (S));
- C : Node_Id;
- D : Node_Id;
- Rais : Node_Id;
+ procedure Constrain_Concurrent
+ (Def_Id : in out Entity_Id;
+ SI : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character)
+ is
+ -- Retrieve Base_Type to ensure getting to the concurrent type in the
+ -- case of a private subtype (needed when only doing semantic analysis).
+
+ T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI)));
+ T_Val : Entity_Id;
begin
- Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype);
- Set_Etype (Def_Id, Base_Type (T));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- Set_Small_Value (Def_Id, Small_Value (T));
+ if Is_Access_Type (T_Ent) then
+ T_Ent := Designated_Type (T_Ent);
+ end if;
- -- Process the constraint
+ T_Val := Corresponding_Record_Type (T_Ent);
- C := Constraint (S);
+ if Present (T_Val) then
- -- Delta constraint present
+ if No (Def_Id) then
+ Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+ end if;
- if Nkind (C) = N_Delta_Constraint then
+ Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
- Check_SPARK_05_Restriction ("delta constraint is not allowed", S);
- Check_Restriction (No_Obsolescent_Features, C);
+ Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
+ Set_Corresponding_Record_Type (Def_Id,
+ Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod));
- if Warn_On_Obsolescent_Feature then
- Error_Msg_S
- ("subtype delta constraint is an " &
- "obsolescent feature (RM J.3(7))?j?");
- end if;
+ else
+ -- If there is no associated record, expansion is disabled and this
+ -- is a generic context. Create a subtype in any case, so that
+ -- semantic analysis can proceed.
- D := Delta_Expression (C);
- Analyze_And_Resolve (D, Any_Real);
- Check_Delta_Expression (D);
- Set_Delta_Value (Def_Id, Expr_Value_R (D));
+ if No (Def_Id) then
+ Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+ end if;
- -- Check that delta value is in range. Obviously we can do this
- -- at compile time, but it is strictly a runtime check, and of
- -- course there is an ACVC test that checks this.
+ Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+ end if;
+ end Constrain_Concurrent;
- if Delta_Value (Def_Id) < Delta_Value (T) then
- Error_Msg_N ("??delta value is too small", D);
- Rais :=
- Make_Raise_Constraint_Error (Sloc (D),
- Reason => CE_Range_Check_Failed);
- Insert_Action (Declaration_Node (Def_Id), Rais);
- end if;
+ ------------------------------------
+ -- Constrain_Corresponding_Record --
+ ------------------------------------
- C := Range_Constraint (C);
+ function Constrain_Corresponding_Record
+ (Prot_Subt : Entity_Id;
+ Corr_Rec : Entity_Id;
+ Related_Nod : Node_Id) return Entity_Id
+ is
+ T_Sub : constant Entity_Id :=
+ Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C');
- -- No delta constraint present
+ begin
+ Set_Etype (T_Sub, Corr_Rec);
+ Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
+ Set_Is_Constrained (T_Sub, True);
+ Set_First_Entity (T_Sub, First_Entity (Corr_Rec));
+ Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec));
- else
- Set_Delta_Value (Def_Id, Delta_Value (T));
+ if Has_Discriminants (Prot_Subt) then -- False only if errors.
+ Set_Discriminant_Constraint
+ (T_Sub, Discriminant_Constraint (Prot_Subt));
+ Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub);
+ Create_Constrained_Components
+ (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub));
end if;
- -- Range constraint present
-
- if Nkind (C) = N_Range_Constraint then
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
+ Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub));
- -- No range constraint present
+ if Ekind (Scope (Prot_Subt)) /= E_Record_Type then
+ Conditional_Delay (T_Sub, Corr_Rec);
else
- pragma Assert (No (C));
- Set_Scalar_Range (Def_Id, Scalar_Range (T));
+ -- This is a component subtype: it will be frozen in the context of
+ -- the enclosing record's init_proc, so that discriminant references
+ -- are resolved to discriminals. (Note: we used to skip freezing
+ -- altogether in that case, which caused errors downstream for
+ -- components of a bit packed array type).
+ Set_Has_Delayed_Freeze (T_Sub);
end if;
- Set_Discrete_RM_Size (Def_Id);
-
- -- Unconditionally delay the freeze, since we cannot set size
- -- information in all cases correctly until the freeze point.
-
- Set_Has_Delayed_Freeze (Def_Id);
- end Constrain_Ordinary_Fixed;
+ return T_Sub;
+ end Constrain_Corresponding_Record;
-----------------------
- -- Contain_Interface --
+ -- Constrain_Decimal --
-----------------------
- function Contain_Interface
- (Iface : Entity_Id;
- Ifaces : Elist_Id) return Boolean
- is
- Iface_Elmt : Elmt_Id;
+ procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : constant Node_Id := Constraint (S);
+ Loc : constant Source_Ptr := Sloc (C);
+ Range_Expr : Node_Id;
+ Digits_Expr : Node_Id;
+ Digits_Val : Uint;
+ Bound_Val : Ureal;
begin
- if Present (Ifaces) then
- Iface_Elmt := First_Elmt (Ifaces);
- while Present (Iface_Elmt) loop
- if Node (Iface_Elmt) = Iface then
- return True;
- end if;
+ Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
- Next_Elmt (Iface_Elmt);
- end loop;
- end if;
+ if Nkind (C) = N_Range_Constraint then
+ Range_Expr := Range_Expression (C);
+ Digits_Val := Digits_Value (T);
- return False;
- end Contain_Interface;
+ else
+ pragma Assert (Nkind (C) = N_Digits_Constraint);
- ---------------------------
- -- Convert_Scalar_Bounds --
- ---------------------------
+ Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
- procedure Convert_Scalar_Bounds
- (N : Node_Id;
- Parent_Type : Entity_Id;
- Derived_Type : Entity_Id;
- Loc : Source_Ptr)
- is
- Implicit_Base : constant Entity_Id := Base_Type (Derived_Type);
+ Digits_Expr := Digits_Expression (C);
+ Analyze_And_Resolve (Digits_Expr, Any_Integer);
- Lo : Node_Id;
- Hi : Node_Id;
- Rng : Node_Id;
+ Check_Digits_Expression (Digits_Expr);
+ Digits_Val := Expr_Value (Digits_Expr);
- begin
- -- Defend against previous errors
+ if Digits_Val > Digits_Value (T) then
+ Error_Msg_N
+ ("digits expression is incompatible with subtype", C);
+ Digits_Val := Digits_Value (T);
+ end if;
- if No (Scalar_Range (Derived_Type)) then
- Check_Error_Detected;
- return;
+ if Present (Range_Constraint (C)) then
+ Range_Expr := Range_Expression (Range_Constraint (C));
+ else
+ Range_Expr := Empty;
+ end if;
end if;
- Lo := Build_Scalar_Bound
- (Type_Low_Bound (Derived_Type),
- Parent_Type, Implicit_Base);
-
- Hi := Build_Scalar_Bound
- (Type_High_Bound (Derived_Type),
- Parent_Type, Implicit_Base);
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Delta_Value (Def_Id, Delta_Value (T));
+ Set_Scale_Value (Def_Id, Scale_Value (T));
+ Set_Small_Value (Def_Id, Small_Value (T));
+ Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T));
+ Set_Digits_Value (Def_Id, Digits_Val);
- Rng :=
- Make_Range (Loc,
- Low_Bound => Lo,
- High_Bound => Hi);
+ -- Manufacture range from given digits value if no range present
- Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type));
+ if No (Range_Expr) then
+ Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T);
+ Range_Expr :=
+ Make_Range (Loc,
+ Low_Bound =>
+ Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))),
+ High_Bound =>
+ Convert_To (T, Make_Real_Literal (Loc, Bound_Val)));
+ end if;
- Set_Parent (Rng, N);
- Set_Scalar_Range (Derived_Type, Rng);
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T);
+ Set_Discrete_RM_Size (Def_Id);
- -- Analyze the bounds
+ -- Unconditionally delay the freeze, since we cannot set size
+ -- information in all cases correctly until the freeze point.
- Analyze_And_Resolve (Lo, Implicit_Base);
- Analyze_And_Resolve (Hi, Implicit_Base);
+ Set_Has_Delayed_Freeze (Def_Id);
+ end Constrain_Decimal;
- -- Analyze the range itself, except that we do not analyze it if
- -- the bounds are real literals, and we have a fixed-point type.
- -- The reason for this is that we delay setting the bounds in this
- -- case till we know the final Small and Size values (see circuit
- -- in Freeze.Freeze_Fixed_Point_Type for further details).
+ ----------------------------------
+ -- Constrain_Discriminated_Type --
+ ----------------------------------
- if Is_Fixed_Point_Type (Parent_Type)
- and then Nkind (Lo) = N_Real_Literal
- and then Nkind (Hi) = N_Real_Literal
- then
- return;
+ procedure Constrain_Discriminated_Type
+ (Def_Id : Entity_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id;
+ For_Access : Boolean := False)
+ is
+ E : constant Entity_Id := Entity (Subtype_Mark (S));
+ T : Entity_Id;
+ C : Node_Id;
+ Elist : Elist_Id := New_Elmt_List;
- -- Here we do the analysis of the range
+ procedure Fixup_Bad_Constraint;
+ -- This is called after finding a bad constraint, and after having
+ -- posted an appropriate error message. The mission is to leave the
+ -- entity T in as reasonable state as possible.
- -- Note: we do this manually, since if we do a normal Analyze and
- -- Resolve call, there are problems with the conversions used for
- -- the derived type range.
+ --------------------------
+ -- Fixup_Bad_Constraint --
+ --------------------------
- else
- Set_Etype (Rng, Implicit_Base);
- Set_Analyzed (Rng, True);
- end if;
- end Convert_Scalar_Bounds;
+ procedure Fixup_Bad_Constraint is
+ begin
+ -- Set a reasonable Ekind for the entity. For an incomplete type,
+ -- we can't do much, but for other types, we can set the proper
+ -- corresponding subtype kind.
- -------------------
- -- Copy_And_Swap --
- -------------------
+ if Ekind (T) = E_Incomplete_Type then
+ Set_Ekind (Def_Id, Ekind (T));
+ else
+ Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+ end if;
- procedure Copy_And_Swap (Priv, Full : Entity_Id) is
- begin
- -- Initialize new full declaration entity by copying the pertinent
- -- fields of the corresponding private declaration entity.
+ -- Set Etype to the known type, to reduce chances of cascaded errors
- -- We temporarily set Ekind to a value appropriate for a type to
- -- avoid assert failures in Einfo from checking for setting type
- -- attributes on something that is not a type. Ekind (Priv) is an
- -- appropriate choice, since it allowed the attributes to be set
- -- in the first place. This Ekind value will be modified later.
+ Set_Etype (Def_Id, E);
+ Set_Error_Posted (Def_Id);
+ end Fixup_Bad_Constraint;
- Set_Ekind (Full, Ekind (Priv));
+ -- Start of processing for Constrain_Discriminated_Type
- -- Also set Etype temporarily to Any_Type, again, in the absence
- -- of errors, it will be properly reset, and if there are errors,
- -- then we want a value of Any_Type to remain.
+ begin
+ C := Constraint (S);
- Set_Etype (Full, Any_Type);
-
- -- Now start copying attributes
+ -- A discriminant constraint is only allowed in a subtype indication,
+ -- after a subtype mark. This subtype mark must denote either a type
+ -- with discriminants, or an access type whose designated type is a
+ -- type with discriminants. A discriminant constraint specifies the
+ -- values of these discriminants (RM 3.7.2(5)).
- Set_Has_Discriminants (Full, Has_Discriminants (Priv));
+ T := Base_Type (Entity (Subtype_Mark (S)));
- if Has_Discriminants (Full) then
- Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
- Set_Stored_Constraint (Full, Stored_Constraint (Priv));
+ if Is_Access_Type (T) then
+ T := Designated_Type (T);
end if;
- Set_First_Rep_Item (Full, First_Rep_Item (Priv));
- Set_Homonym (Full, Homonym (Priv));
- Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv));
- Set_Is_Public (Full, Is_Public (Priv));
- Set_Is_Pure (Full, Is_Pure (Priv));
- Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv));
- Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv));
- Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv));
- Set_Has_Pragma_Unreferenced_Objects
- (Full, Has_Pragma_Unreferenced_Objects
- (Priv));
-
- Conditional_Delay (Full, Priv);
+ -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
+ -- Avoid generating an error for access-to-incomplete subtypes.
- if Is_Tagged_Type (Full) then
- Set_Direct_Primitive_Operations (Full,
- Direct_Primitive_Operations (Priv));
+ if Ada_Version >= Ada_2005
+ and then Ekind (T) = E_Incomplete_Type
+ and then Nkind (Parent (S)) = N_Subtype_Declaration
+ and then not Is_Itype (Def_Id)
+ then
+ -- A little sanity check, emit an error message if the type
+ -- has discriminants to begin with. Type T may be a regular
+ -- incomplete type or imported via a limited with clause.
- if Is_Base_Type (Priv) then
- Set_Class_Wide_Type (Full, Class_Wide_Type (Priv));
+ if Has_Discriminants (T)
+ or else (From_Limited_With (T)
+ and then Present (Non_Limited_View (T))
+ and then Nkind (Parent (Non_Limited_View (T))) =
+ N_Full_Type_Declaration
+ and then Present (Discriminant_Specifications
+ (Parent (Non_Limited_View (T)))))
+ then
+ Error_Msg_N
+ ("(Ada 2005) incomplete subtype may not be constrained", C);
+ else
+ Error_Msg_N ("invalid constraint: type has no discriminant", C);
end if;
- end if;
- Set_Is_Volatile (Full, Is_Volatile (Priv));
- Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv));
- Set_Scope (Full, Scope (Priv));
- Set_Next_Entity (Full, Next_Entity (Priv));
- Set_First_Entity (Full, First_Entity (Priv));
- Set_Last_Entity (Full, Last_Entity (Priv));
+ Fixup_Bad_Constraint;
+ return;
- -- If access types have been recorded for later handling, keep them in
- -- the full view so that they get handled when the full view freeze
- -- node is expanded.
+ -- Check that the type has visible discriminants. The type may be
+ -- a private type with unknown discriminants whose full view has
+ -- discriminants which are invisible.
- if Present (Freeze_Node (Priv))
- and then Present (Access_Types_To_Process (Freeze_Node (Priv)))
+ elsif not Has_Discriminants (T)
+ or else
+ (Has_Unknown_Discriminants (T)
+ and then Is_Private_Type (T))
then
- Ensure_Freeze_Node (Full);
- Set_Access_Types_To_Process
- (Freeze_Node (Full),
- Access_Types_To_Process (Freeze_Node (Priv)));
+ Error_Msg_N ("invalid constraint: type has no discriminant", C);
+ Fixup_Bad_Constraint;
+ return;
+
+ elsif Is_Constrained (E)
+ or else (Ekind (E) = E_Class_Wide_Subtype
+ and then Present (Discriminant_Constraint (E)))
+ then
+ Error_Msg_N ("type is already constrained", Subtype_Mark (S));
+ Fixup_Bad_Constraint;
+ return;
end if;
- -- Swap the two entities. Now Private is the full type entity and Full
- -- is the private one. They will be swapped back at the end of the
- -- private part. This swapping ensures that the entity that is visible
- -- in the private part is the full declaration.
+ -- T may be an unconstrained subtype (e.g. a generic actual).
+ -- Constraint applies to the base type.
- Exchange_Entities (Priv, Full);
- Append_Entity (Full, Scope (Full));
- end Copy_And_Swap;
+ T := Base_Type (T);
- -------------------------------------
- -- Copy_Array_Base_Type_Attributes --
- -------------------------------------
+ Elist := Build_Discriminant_Constraints (T, S);
- procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
- begin
- Set_Component_Alignment (T1, Component_Alignment (T2));
- Set_Component_Type (T1, Component_Type (T2));
- Set_Component_Size (T1, Component_Size (T2));
- Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
- Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
- Set_Has_Protected (T1, Has_Protected (T2));
- Set_Has_Task (T1, Has_Task (T2));
- Set_Is_Packed (T1, Is_Packed (T2));
- Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
- Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
- Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2));
- end Copy_Array_Base_Type_Attributes;
+ -- If the list returned was empty we had an error in building the
+ -- discriminant constraint. We have also already signalled an error
+ -- in the incomplete type case
- -----------------------------------
- -- Copy_Array_Subtype_Attributes --
- -----------------------------------
+ if Is_Empty_Elmt_List (Elist) then
+ Fixup_Bad_Constraint;
+ return;
+ end if;
+
+ Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
+ end Constrain_Discriminated_Type;
+
+ ---------------------------
+ -- Constrain_Enumeration --
+ ---------------------------
+
+ procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : constant Node_Id := Constraint (S);
- procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
begin
- Set_Size_Info (T1, T2);
+ Set_Ekind (Def_Id, E_Enumeration_Subtype);
- Set_First_Index (T1, First_Index (T2));
- Set_Is_Aliased (T1, Is_Aliased (T2));
- Set_Is_Volatile (T1, Is_Volatile (T2));
- Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2));
- Set_Is_Constrained (T1, Is_Constrained (T2));
- Set_Depends_On_Private (T1, Has_Private_Component (T2));
- Set_First_Rep_Item (T1, First_Rep_Item (T2));
- Set_Convention (T1, Convention (T2));
- Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
- Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
- Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2));
- end Copy_Array_Subtype_Attributes;
+ Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
- -----------------------------------
- -- Create_Constrained_Components --
- -----------------------------------
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
- procedure Create_Constrained_Components
- (Subt : Entity_Id;
- Decl_Node : Node_Id;
- Typ : Entity_Id;
- Constraints : Elist_Id)
- is
- Loc : constant Source_Ptr := Sloc (Subt);
- Comp_List : constant Elist_Id := New_Elmt_List;
- Parent_Type : constant Entity_Id := Etype (Typ);
- Assoc_List : constant List_Id := New_List;
- Discr_Val : Elmt_Id;
- Errors : Boolean;
- New_C : Entity_Id;
- Old_C : Entity_Id;
- Is_Static : Boolean := True;
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
- procedure Collect_Fixed_Components (Typ : Entity_Id);
- -- Collect parent type components that do not appear in a variant part
+ Set_Discrete_RM_Size (Def_Id);
+ end Constrain_Enumeration;
- procedure Create_All_Components;
- -- Iterate over Comp_List to create the components of the subtype
+ ----------------------
+ -- Constrain_Float --
+ ----------------------
- function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
- -- Creates a new component from Old_Compon, copying all the fields from
- -- it, including its Etype, inserts the new component in the Subt entity
- -- chain and returns the new component.
+ procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : Node_Id;
+ D : Node_Id;
+ Rais : Node_Id;
- function Is_Variant_Record (T : Entity_Id) return Boolean;
- -- If true, and discriminants are static, collect only components from
- -- variants selected by discriminant values.
+ begin
+ Set_Ekind (Def_Id, E_Floating_Point_Subtype);
- ------------------------------
- -- Collect_Fixed_Components --
- ------------------------------
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- procedure Collect_Fixed_Components (Typ : Entity_Id) is
- begin
- -- Build association list for discriminants, and find components of the
- -- variant part selected by the values of the discriminants.
+ -- Process the constraint
- Old_C := First_Discriminant (Typ);
- Discr_Val := First_Elmt (Constraints);
- while Present (Old_C) loop
- Append_To (Assoc_List,
- Make_Component_Association (Loc,
- Choices => New_List (New_Occurrence_Of (Old_C, Loc)),
- Expression => New_Copy (Node (Discr_Val))));
+ C := Constraint (S);
- Next_Elmt (Discr_Val);
- Next_Discriminant (Old_C);
- end loop;
+ -- Digits constraint present
- -- The tag and the possible parent component are unconditionally in
- -- the subtype.
+ if Nkind (C) = N_Digits_Constraint then
- if Is_Tagged_Type (Typ)
- or else Has_Controlled_Component (Typ)
- then
- Old_C := First_Component (Typ);
- while Present (Old_C) loop
- if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then
- Append_Elmt (Old_C, Comp_List);
- end if;
+ Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
+ Check_Restriction (No_Obsolescent_Features, C);
- Next_Component (Old_C);
- end loop;
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("subtype digits constraint is an " &
+ "obsolescent feature (RM J.3(8))?j?", C);
end if;
- end Collect_Fixed_Components;
- ---------------------------
- -- Create_All_Components --
- ---------------------------
+ D := Digits_Expression (C);
+ Analyze_And_Resolve (D, Any_Integer);
+ Check_Digits_Expression (D);
+ Set_Digits_Value (Def_Id, Expr_Value (D));
- procedure Create_All_Components is
- Comp : Elmt_Id;
+ -- Check that digits value is in range. Obviously we can do this
+ -- at compile time, but it is strictly a runtime check, and of
+ -- course there is an ACVC test that checks this.
- begin
- Comp := First_Elmt (Comp_List);
- while Present (Comp) loop
- Old_C := Node (Comp);
- New_C := Create_Component (Old_C);
-
- Set_Etype
- (New_C,
- Constrain_Component_Type
- (Old_C, Subt, Decl_Node, Typ, Constraints));
- Set_Is_Public (New_C, Is_Public (Subt));
+ if Digits_Value (Def_Id) > Digits_Value (T) then
+ Error_Msg_Uint_1 := Digits_Value (T);
+ Error_Msg_N ("??digits value is too large, maximum is ^", D);
+ Rais :=
+ Make_Raise_Constraint_Error (Sloc (D),
+ Reason => CE_Range_Check_Failed);
+ Insert_Action (Declaration_Node (Def_Id), Rais);
+ end if;
- Next_Elmt (Comp);
- end loop;
- end Create_All_Components;
+ C := Range_Constraint (C);
- ----------------------
- -- Create_Component --
- ----------------------
+ -- No digits constraint present
- function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
- New_Compon : constant Entity_Id := New_Copy (Old_Compon);
+ else
+ Set_Digits_Value (Def_Id, Digits_Value (T));
+ end if;
- begin
- if Ekind (Old_Compon) = E_Discriminant
- and then Is_Completely_Hidden (Old_Compon)
- then
- -- This is a shadow discriminant created for a discriminant of
- -- the parent type, which needs to be present in the subtype.
- -- Give the shadow discriminant an internal name that cannot
- -- conflict with that of visible components.
+ -- Range constraint present
- Set_Chars (New_Compon, New_Internal_Name ('C'));
- end if;
+ if Nkind (C) = N_Range_Constraint then
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
- -- Set the parent so we have a proper link for freezing etc. This is
- -- not a real parent pointer, since of course our parent does not own
- -- up to us and reference us, we are an illegitimate child of the
- -- original parent.
+ -- No range constraint present
- Set_Parent (New_Compon, Parent (Old_Compon));
+ else
+ pragma Assert (No (C));
+ Set_Scalar_Range (Def_Id, Scalar_Range (T));
+ end if;
- -- If the old component's Esize was already determined and is a
- -- static value, then the new component simply inherits it. Otherwise
- -- the old component's size may require run-time determination, but
- -- the new component's size still might be statically determinable
- -- (if, for example it has a static constraint). In that case we want
- -- Layout_Type to recompute the component's size, so we reset its
- -- size and positional fields.
+ Set_Is_Constrained (Def_Id);
+ end Constrain_Float;
- if Frontend_Layout_On_Target
- and then not Known_Static_Esize (Old_Compon)
- then
- Set_Esize (New_Compon, Uint_0);
- Init_Normalized_First_Bit (New_Compon);
- Init_Normalized_Position (New_Compon);
- Init_Normalized_Position_Max (New_Compon);
- end if;
+ ---------------------
+ -- Constrain_Index --
+ ---------------------
- -- We do not want this node marked as Comes_From_Source, since
- -- otherwise it would get first class status and a separate cross-
- -- reference line would be generated. Illegitimate children do not
- -- rate such recognition.
+ procedure Constrain_Index
+ (Index : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character;
+ Suffix_Index : Nat)
+ is
+ Def_Id : Entity_Id;
+ R : Node_Id := Empty;
+ T : constant Entity_Id := Etype (Index);
- Set_Comes_From_Source (New_Compon, False);
+ begin
+ if Nkind (S) = N_Range
+ or else
+ (Nkind (S) = N_Attribute_Reference
+ and then Attribute_Name (S) = Name_Range)
+ then
+ -- A Range attribute will be transformed into N_Range by Resolve
- -- But it is a real entity, and a birth certificate must be properly
- -- registered by entering it into the entity list.
+ Analyze (S);
+ Set_Etype (S, T);
+ R := S;
- Enter_Name (New_Compon);
+ Process_Range_Expr_In_Decl (R, T);
- return New_Compon;
- end Create_Component;
+ if not Error_Posted (S)
+ and then
+ (Nkind (S) /= N_Range
+ or else not Covers (T, (Etype (Low_Bound (S))))
+ or else not Covers (T, (Etype (High_Bound (S)))))
+ then
+ if Base_Type (T) /= Any_Type
+ and then Etype (Low_Bound (S)) /= Any_Type
+ and then Etype (High_Bound (S)) /= Any_Type
+ then
+ Error_Msg_N ("range expected", S);
+ end if;
+ end if;
- -----------------------
- -- Is_Variant_Record --
- -----------------------
+ elsif Nkind (S) = N_Subtype_Indication then
- function Is_Variant_Record (T : Entity_Id) return Boolean is
- begin
- return Nkind (Parent (T)) = N_Full_Type_Declaration
- and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition
- and then Present (Component_List (Type_Definition (Parent (T))))
- and then
- Present
- (Variant_Part (Component_List (Type_Definition (Parent (T)))));
- end Is_Variant_Record;
+ -- The parser has verified that this is a discrete indication
- -- Start of processing for Create_Constrained_Components
+ Resolve_Discrete_Subtype_Indication (S, T);
+ Bad_Predicated_Subtype_Use
+ ("subtype& has predicate, not allowed in index constraint",
+ S, Entity (Subtype_Mark (S)));
- begin
- pragma Assert (Subt /= Base_Type (Subt));
- pragma Assert (Typ = Base_Type (Typ));
+ R := Range_Expression (Constraint (S));
- Set_First_Entity (Subt, Empty);
- Set_Last_Entity (Subt, Empty);
+ -- Capture values of bounds and generate temporaries for them if
+ -- needed, since checks may cause duplication of the expressions
+ -- which must not be reevaluated.
- -- Check whether constraint is fully static, in which case we can
- -- optimize the list of components.
+ -- The forced evaluation removes side effects from expressions, which
+ -- should occur also in GNATprove mode. Otherwise, we end up with
+ -- unexpected insertions of actions at places where this is not
+ -- supposed to occur, e.g. on default parameters of a call.
- Discr_Val := First_Elmt (Constraints);
- while Present (Discr_Val) loop
- if not Is_OK_Static_Expression (Node (Discr_Val)) then
- Is_Static := False;
- exit;
+ if Expander_Active or GNATprove_Mode then
+ Force_Evaluation (Low_Bound (R));
+ Force_Evaluation (High_Bound (R));
end if;
- Next_Elmt (Discr_Val);
- end loop;
+ elsif Nkind (S) = N_Discriminant_Association then
- Set_Has_Static_Discriminants (Subt, Is_Static);
+ -- Syntactically valid in subtype indication
- Push_Scope (Subt);
+ Error_Msg_N ("invalid index constraint", S);
+ Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
+ return;
- -- Inherit the discriminants of the parent type
+ -- Subtype_Mark case, no anonymous subtypes to construct
- Add_Discriminants : declare
- Num_Disc : Int;
- Num_Gird : Int;
+ else
+ Analyze (S);
- begin
- Num_Disc := 0;
- Old_C := First_Discriminant (Typ);
+ if Is_Entity_Name (S) then
+ if not Is_Type (Entity (S)) then
+ Error_Msg_N ("expect subtype mark for index constraint", S);
- while Present (Old_C) loop
- Num_Disc := Num_Disc + 1;
- New_C := Create_Component (Old_C);
- Set_Is_Public (New_C, Is_Public (Subt));
- Next_Discriminant (Old_C);
- end loop;
+ elsif Base_Type (Entity (S)) /= Base_Type (T) then
+ Wrong_Type (S, Base_Type (T));
- -- For an untagged derived subtype, the number of discriminants may
- -- be smaller than the number of inherited discriminants, because
- -- several of them may be renamed by a single new discriminant or
- -- constrained. In this case, add the hidden discriminants back into
- -- the subtype, because they need to be present if the optimizer of
- -- the GCC 4.x back-end decides to break apart assignments between
- -- objects using the parent view into member-wise assignments.
+ -- Check error of subtype with predicate in index constraint
- Num_Gird := 0;
+ else
+ Bad_Predicated_Subtype_Use
+ ("subtype& has predicate, not allowed in index constraint",
+ S, Entity (S));
+ end if;
- if Is_Derived_Type (Typ)
- and then not Is_Tagged_Type (Typ)
- then
- Old_C := First_Stored_Discriminant (Typ);
+ return;
- while Present (Old_C) loop
- Num_Gird := Num_Gird + 1;
- Next_Stored_Discriminant (Old_C);
- end loop;
+ else
+ Error_Msg_N ("invalid index constraint", S);
+ Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
+ return;
end if;
+ end if;
- if Num_Gird > Num_Disc then
-
- -- Find out multiple uses of new discriminants, and add hidden
- -- components for the extra renamed discriminants. We recognize
- -- multiple uses through the Corresponding_Discriminant of a
- -- new discriminant: if it constrains several old discriminants,
- -- this field points to the last one in the parent type. The
- -- stored discriminants of the derived type have the same name
- -- as those of the parent.
+ Def_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
- declare
- Constr : Elmt_Id;
- New_Discr : Entity_Id;
- Old_Discr : Entity_Id;
+ Set_Etype (Def_Id, Base_Type (T));
- begin
- Constr := First_Elmt (Stored_Constraint (Typ));
- Old_Discr := First_Stored_Discriminant (Typ);
- while Present (Constr) loop
- if Is_Entity_Name (Node (Constr))
- and then Ekind (Entity (Node (Constr))) = E_Discriminant
- then
- New_Discr := Entity (Node (Constr));
+ if Is_Modular_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
- if Chars (Corresponding_Discriminant (New_Discr)) /=
- Chars (Old_Discr)
- then
- -- The new discriminant has been used to rename a
- -- subsequent old discriminant. Introduce a shadow
- -- component for the current old discriminant.
+ elsif Is_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
- New_C := Create_Component (Old_Discr);
- Set_Original_Record_Component (New_C, Old_Discr);
- end if;
+ else
+ Set_Ekind (Def_Id, E_Enumeration_Subtype);
+ Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+ Set_First_Literal (Def_Id, First_Literal (T));
+ end if;
- else
- -- The constraint has eliminated the old discriminant.
- -- Introduce a shadow component.
+ Set_Size_Info (Def_Id, (T));
+ Set_RM_Size (Def_Id, RM_Size (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- New_C := Create_Component (Old_Discr);
- Set_Original_Record_Component (New_C, Old_Discr);
- end if;
+ Set_Scalar_Range (Def_Id, R);
- Next_Elmt (Constr);
- Next_Stored_Discriminant (Old_Discr);
- end loop;
- end;
- end if;
- end Add_Discriminants;
+ Set_Etype (S, Def_Id);
+ Set_Discrete_RM_Size (Def_Id);
+ end Constrain_Index;
- if Is_Static
- and then Is_Variant_Record (Typ)
- then
- Collect_Fixed_Components (Typ);
+ -----------------------
+ -- Constrain_Integer --
+ -----------------------
- Gather_Components (
- Typ,
- Component_List (Type_Definition (Parent (Typ))),
- Governed_By => Assoc_List,
- Into => Comp_List,
- Report_Errors => Errors);
- pragma Assert (not Errors);
+ procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : constant Node_Id := Constraint (S);
- Create_All_Components;
+ begin
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
- -- If the subtype declaration is created for a tagged type derivation
- -- with constraints, we retrieve the record definition of the parent
- -- type to select the components of the proper variant.
+ if Is_Modular_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+ else
+ Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+ end if;
- elsif Is_Static
- and then Is_Tagged_Type (Typ)
- and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
- and then
- Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition
- and then Is_Variant_Record (Parent_Type)
- then
- Collect_Fixed_Components (Typ);
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Discrete_RM_Size (Def_Id);
+ end Constrain_Integer;
- Gather_Components (
- Typ,
- Component_List (Type_Definition (Parent (Parent_Type))),
- Governed_By => Assoc_List,
- Into => Comp_List,
- Report_Errors => Errors);
- pragma Assert (not Errors);
+ ------------------------------
+ -- Constrain_Ordinary_Fixed --
+ ------------------------------
- -- If the tagged derivation has a type extension, collect all the
- -- new components therein.
+ procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : Node_Id;
+ D : Node_Id;
+ Rais : Node_Id;
- if Present
- (Record_Extension_Part (Type_Definition (Parent (Typ))))
- then
- Old_C := First_Component (Typ);
- while Present (Old_C) loop
- if Original_Record_Component (Old_C) = Old_C
- and then Chars (Old_C) /= Name_uTag
- and then Chars (Old_C) /= Name_uParent
- then
- Append_Elmt (Old_C, Comp_List);
- end if;
+ begin
+ Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype);
+ Set_Etype (Def_Id, Base_Type (T));
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Small_Value (Def_Id, Small_Value (T));
- Next_Component (Old_C);
- end loop;
- end if;
+ -- Process the constraint
- Create_All_Components;
+ C := Constraint (S);
- else
- -- If discriminants are not static, or if this is a multi-level type
- -- extension, we have to include all components of the parent type.
+ -- Delta constraint present
- Old_C := First_Component (Typ);
- while Present (Old_C) loop
- New_C := Create_Component (Old_C);
+ if Nkind (C) = N_Delta_Constraint then
- Set_Etype
- (New_C,
- Constrain_Component_Type
- (Old_C, Subt, Decl_Node, Typ, Constraints));
- Set_Is_Public (New_C, Is_Public (Subt));
+ Check_SPARK_05_Restriction ("delta constraint is not allowed", S);
+ Check_Restriction (No_Obsolescent_Features, C);
- Next_Component (Old_C);
- end loop;
- end if;
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_S
+ ("subtype delta constraint is an " &
+ "obsolescent feature (RM J.3(7))?j?");
+ end if;
- End_Scope;
- end Create_Constrained_Components;
+ D := Delta_Expression (C);
+ Analyze_And_Resolve (D, Any_Real);
+ Check_Delta_Expression (D);
+ Set_Delta_Value (Def_Id, Expr_Value_R (D));
- ------------------------------------------
- -- Decimal_Fixed_Point_Type_Declaration --
- ------------------------------------------
+ -- Check that delta value is in range. Obviously we can do this
+ -- at compile time, but it is strictly a runtime check, and of
+ -- course there is an ACVC test that checks this.
- procedure Decimal_Fixed_Point_Type_Declaration
- (T : Entity_Id;
- Def : Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (Def);
- Digs_Expr : constant Node_Id := Digits_Expression (Def);
- Delta_Expr : constant Node_Id := Delta_Expression (Def);
- Implicit_Base : Entity_Id;
- Digs_Val : Uint;
- Delta_Val : Ureal;
- Scale_Val : Uint;
- Bound_Val : Ureal;
+ if Delta_Value (Def_Id) < Delta_Value (T) then
+ Error_Msg_N ("??delta value is too small", D);
+ Rais :=
+ Make_Raise_Constraint_Error (Sloc (D),
+ Reason => CE_Range_Check_Failed);
+ Insert_Action (Declaration_Node (Def_Id), Rais);
+ end if;
- begin
- Check_SPARK_05_Restriction
- ("decimal fixed point type is not allowed", Def);
- Check_Restriction (No_Fixed_Point, Def);
+ C := Range_Constraint (C);
- -- Create implicit base type
+ -- No delta constraint present
- Implicit_Base :=
- Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
- Set_Etype (Implicit_Base, Implicit_Base);
+ else
+ Set_Delta_Value (Def_Id, Delta_Value (T));
+ end if;
- -- Analyze and process delta expression
+ -- Range constraint present
- Analyze_And_Resolve (Delta_Expr, Universal_Real);
+ if Nkind (C) = N_Range_Constraint then
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
- Check_Delta_Expression (Delta_Expr);
- Delta_Val := Expr_Value_R (Delta_Expr);
+ -- No range constraint present
- -- Check delta is power of 10, and determine scale value from it
+ else
+ pragma Assert (No (C));
+ Set_Scalar_Range (Def_Id, Scalar_Range (T));
- declare
- Val : Ureal;
+ end if;
- begin
- Scale_Val := Uint_0;
- Val := Delta_Val;
+ Set_Discrete_RM_Size (Def_Id);
- if Val < Ureal_1 then
- while Val < Ureal_1 loop
- Val := Val * Ureal_10;
- Scale_Val := Scale_Val + 1;
- end loop;
+ -- Unconditionally delay the freeze, since we cannot set size
+ -- information in all cases correctly until the freeze point.
- if Scale_Val > 18 then
- Error_Msg_N ("scale exceeds maximum value of 18", Def);
- Scale_Val := UI_From_Int (+18);
- end if;
+ Set_Has_Delayed_Freeze (Def_Id);
+ end Constrain_Ordinary_Fixed;
- else
- while Val > Ureal_1 loop
- Val := Val / Ureal_10;
- Scale_Val := Scale_Val - 1;
- end loop;
+ -----------------------
+ -- Contain_Interface --
+ -----------------------
- if Scale_Val < -18 then
- Error_Msg_N ("scale is less than minimum value of -18", Def);
- Scale_Val := UI_From_Int (-18);
+ function Contain_Interface
+ (Iface : Entity_Id;
+ Ifaces : Elist_Id) return Boolean
+ is
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ if Present (Ifaces) then
+ Iface_Elmt := First_Elmt (Ifaces);
+ while Present (Iface_Elmt) loop
+ if Node (Iface_Elmt) = Iface then
+ return True;
end if;
- end if;
- if Val /= Ureal_1 then
- Error_Msg_N ("delta expression must be a power of 10", Def);
- Delta_Val := Ureal_10 ** (-Scale_Val);
- end if;
- end;
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
- -- Set delta, scale and small (small = delta for decimal type)
+ return False;
+ end Contain_Interface;
- Set_Delta_Value (Implicit_Base, Delta_Val);
- Set_Scale_Value (Implicit_Base, Scale_Val);
- Set_Small_Value (Implicit_Base, Delta_Val);
+ ---------------------------
+ -- Convert_Scalar_Bounds --
+ ---------------------------
- -- Analyze and process digits expression
+ procedure Convert_Scalar_Bounds
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Loc : Source_Ptr)
+ is
+ Implicit_Base : constant Entity_Id := Base_Type (Derived_Type);
- Analyze_And_Resolve (Digs_Expr, Any_Integer);
- Check_Digits_Expression (Digs_Expr);
- Digs_Val := Expr_Value (Digs_Expr);
+ Lo : Node_Id;
+ Hi : Node_Id;
+ Rng : Node_Id;
- if Digs_Val > 18 then
- Digs_Val := UI_From_Int (+18);
- Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
- end if;
+ begin
+ -- Defend against previous errors
- Set_Digits_Value (Implicit_Base, Digs_Val);
- Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;
+ if No (Scalar_Range (Derived_Type)) then
+ Check_Error_Detected;
+ return;
+ end if;
- -- Set range of base type from digits value for now. This will be
- -- expanded to represent the true underlying base range by Freeze.
+ Lo := Build_Scalar_Bound
+ (Type_Low_Bound (Derived_Type),
+ Parent_Type, Implicit_Base);
- Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val);
+ Hi := Build_Scalar_Bound
+ (Type_High_Bound (Derived_Type),
+ Parent_Type, Implicit_Base);
- -- Note: We leave size as zero for now, size will be set at freeze
- -- time. We have to do this for ordinary fixed-point, because the size
- -- depends on the specified small, and we might as well do the same for
- -- decimal fixed-point.
+ Rng :=
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi);
- pragma Assert (Esize (Implicit_Base) = Uint_0);
+ Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type));
- -- If there are bounds given in the declaration use them as the
- -- bounds of the first named subtype.
+ Set_Parent (Rng, N);
+ Set_Scalar_Range (Derived_Type, Rng);
- if Present (Real_Range_Specification (Def)) then
- declare
- RRS : constant Node_Id := Real_Range_Specification (Def);
- Low : constant Node_Id := Low_Bound (RRS);
- High : constant Node_Id := High_Bound (RRS);
- Low_Val : Ureal;
- High_Val : Ureal;
+ -- Analyze the bounds
- begin
- Analyze_And_Resolve (Low, Any_Real);
- Analyze_And_Resolve (High, Any_Real);
- Check_Real_Bound (Low);
- Check_Real_Bound (High);
- Low_Val := Expr_Value_R (Low);
- High_Val := Expr_Value_R (High);
+ Analyze_And_Resolve (Lo, Implicit_Base);
+ Analyze_And_Resolve (Hi, Implicit_Base);
- if Low_Val < (-Bound_Val) then
- Error_Msg_N
- ("range low bound too small for digits value", Low);
- Low_Val := -Bound_Val;
- end if;
+ -- Analyze the range itself, except that we do not analyze it if
+ -- the bounds are real literals, and we have a fixed-point type.
+ -- The reason for this is that we delay setting the bounds in this
+ -- case till we know the final Small and Size values (see circuit
+ -- in Freeze.Freeze_Fixed_Point_Type for further details).
- if High_Val > Bound_Val then
- Error_Msg_N
- ("range high bound too large for digits value", High);
- High_Val := Bound_Val;
- end if;
+ if Is_Fixed_Point_Type (Parent_Type)
+ and then Nkind (Lo) = N_Real_Literal
+ and then Nkind (Hi) = N_Real_Literal
+ then
+ return;
- Set_Fixed_Range (T, Loc, Low_Val, High_Val);
- end;
+ -- Here we do the analysis of the range
- -- If no explicit range, use range that corresponds to given
- -- digits value. This will end up as the final range for the
- -- first subtype.
+ -- Note: we do this manually, since if we do a normal Analyze and
+ -- Resolve call, there are problems with the conversions used for
+ -- the derived type range.
else
- Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
+ Set_Etype (Rng, Implicit_Base);
+ Set_Analyzed (Rng, True);
end if;
+ end Convert_Scalar_Bounds;
- -- Complete entity for first subtype
-
- Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
- Set_Etype (T, Implicit_Base);
- Set_Size_Info (T, Implicit_Base);
- Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
- Set_Digits_Value (T, Digs_Val);
- Set_Delta_Value (T, Delta_Val);
- Set_Small_Value (T, Delta_Val);
- Set_Scale_Value (T, Scale_Val);
- Set_Is_Constrained (T);
- end Decimal_Fixed_Point_Type_Declaration;
-
- -----------------------------------
- -- Derive_Progenitor_Subprograms --
- -----------------------------------
-
- procedure Derive_Progenitor_Subprograms
- (Parent_Type : Entity_Id;
- Tagged_Type : Entity_Id)
- is
- E : Entity_Id;
- Elmt : Elmt_Id;
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
- Iface_Subp : Entity_Id;
- New_Subp : Entity_Id := Empty;
- Prim_Elmt : Elmt_Id;
- Subp : Entity_Id;
- Typ : Entity_Id;
+ -------------------
+ -- Copy_And_Swap --
+ -------------------
+ procedure Copy_And_Swap (Priv, Full : Entity_Id) is
begin
- pragma Assert (Ada_Version >= Ada_2005
- and then Is_Record_Type (Tagged_Type)
- and then Is_Tagged_Type (Tagged_Type)
- and then Has_Interfaces (Tagged_Type));
+ -- Initialize new full declaration entity by copying the pertinent
+ -- fields of the corresponding private declaration entity.
- -- Step 1: Transfer to the full-view primitives associated with the
- -- partial-view that cover interface primitives. Conceptually this
- -- work should be done later by Process_Full_View; done here to
- -- simplify its implementation at later stages. It can be safely
- -- done here because interfaces must be visible in the partial and
- -- private view (RM 7.3(7.3/2)).
+ -- We temporarily set Ekind to a value appropriate for a type to
+ -- avoid assert failures in Einfo from checking for setting type
+ -- attributes on something that is not a type. Ekind (Priv) is an
+ -- appropriate choice, since it allowed the attributes to be set
+ -- in the first place. This Ekind value will be modified later.
- -- Small optimization: This work is only required if the parent may
- -- have entities whose Alias attribute reference an interface primitive.
- -- Such a situation may occur if the parent is an abstract type and the
- -- primitive has not been yet overridden or if the parent is a generic
- -- formal type covering interfaces.
+ Set_Ekind (Full, Ekind (Priv));
- -- If the tagged type is not abstract, it cannot have abstract
- -- primitives (the only entities in the list of primitives of
- -- non-abstract tagged types that can reference abstract primitives
- -- through its Alias attribute are the internal entities that have
- -- attribute Interface_Alias, and these entities are generated later
- -- by Add_Internal_Interface_Entities).
+ -- Also set Etype temporarily to Any_Type, again, in the absence
+ -- of errors, it will be properly reset, and if there are errors,
+ -- then we want a value of Any_Type to remain.
- if In_Private_Part (Current_Scope)
- and then (Is_Abstract_Type (Parent_Type)
- or else
- Is_Generic_Type (Parent_Type))
- then
- Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
- while Present (Elmt) loop
- Subp := Node (Elmt);
+ Set_Etype (Full, Any_Type);
- -- At this stage it is not possible to have entities in the list
- -- of primitives that have attribute Interface_Alias.
+ -- Now start copying attributes
- pragma Assert (No (Interface_Alias (Subp)));
+ Set_Has_Discriminants (Full, Has_Discriminants (Priv));
- Typ := Find_Dispatching_Type (Ultimate_Alias (Subp));
+ if Has_Discriminants (Full) then
+ Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
+ Set_Stored_Constraint (Full, Stored_Constraint (Priv));
+ end if;
- if Is_Interface (Typ) then
- E := Find_Primitive_Covering_Interface
- (Tagged_Type => Tagged_Type,
- Iface_Prim => Subp);
+ Set_First_Rep_Item (Full, First_Rep_Item (Priv));
+ Set_Homonym (Full, Homonym (Priv));
+ Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv));
+ Set_Is_Public (Full, Is_Public (Priv));
+ Set_Is_Pure (Full, Is_Pure (Priv));
+ Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv));
+ Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv));
+ Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv));
+ Set_Has_Pragma_Unreferenced_Objects
+ (Full, Has_Pragma_Unreferenced_Objects
+ (Priv));
- if Present (E)
- and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ
- then
- Replace_Elmt (Elmt, E);
- Remove_Homonym (Subp);
- end if;
- end if;
+ Conditional_Delay (Full, Priv);
- Next_Elmt (Elmt);
- end loop;
+ if Is_Tagged_Type (Full) then
+ Set_Direct_Primitive_Operations (Full,
+ Direct_Primitive_Operations (Priv));
+
+ if Is_Base_Type (Priv) then
+ Set_Class_Wide_Type (Full, Class_Wide_Type (Priv));
+ end if;
end if;
- -- Step 2: Add primitives of progenitors that are not implemented by
- -- parents of Tagged_Type.
+ Set_Is_Volatile (Full, Is_Volatile (Priv));
+ Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv));
+ Set_Scope (Full, Scope (Priv));
+ Set_Next_Entity (Full, Next_Entity (Priv));
+ Set_First_Entity (Full, First_Entity (Priv));
+ Set_Last_Entity (Full, Last_Entity (Priv));
- if Present (Interfaces (Base_Type (Tagged_Type))) then
- Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type)));
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
+ -- If access types have been recorded for later handling, keep them in
+ -- the full view so that they get handled when the full view freeze
+ -- node is expanded.
- Prim_Elmt := First_Elmt (Primitive_Operations (Iface));
- while Present (Prim_Elmt) loop
- Iface_Subp := Node (Prim_Elmt);
+ if Present (Freeze_Node (Priv))
+ and then Present (Access_Types_To_Process (Freeze_Node (Priv)))
+ then
+ Ensure_Freeze_Node (Full);
+ Set_Access_Types_To_Process
+ (Freeze_Node (Full),
+ Access_Types_To_Process (Freeze_Node (Priv)));
+ end if;
- -- Exclude derivation of predefined primitives except those
- -- that come from source, or are inherited from one that comes
- -- from source. Required to catch declarations of equality
- -- operators of interfaces. For example:
+ -- Swap the two entities. Now Private is the full type entity and Full
+ -- is the private one. They will be swapped back at the end of the
+ -- private part. This swapping ensures that the entity that is visible
+ -- in the private part is the full declaration.
- -- type Iface is interface;
- -- function "=" (Left, Right : Iface) return Boolean;
+ Exchange_Entities (Priv, Full);
+ Append_Entity (Full, Scope (Full));
+ end Copy_And_Swap;
- if not Is_Predefined_Dispatching_Operation (Iface_Subp)
- or else Comes_From_Source (Ultimate_Alias (Iface_Subp))
- then
- E := Find_Primitive_Covering_Interface
- (Tagged_Type => Tagged_Type,
- Iface_Prim => Iface_Subp);
+ -------------------------------------
+ -- Copy_Array_Base_Type_Attributes --
+ -------------------------------------
- -- If not found we derive a new primitive leaving its alias
- -- attribute referencing the interface primitive.
+ procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
+ begin
+ Set_Component_Alignment (T1, Component_Alignment (T2));
+ Set_Component_Type (T1, Component_Type (T2));
+ Set_Component_Size (T1, Component_Size (T2));
+ Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
+ Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
+ Set_Has_Protected (T1, Has_Protected (T2));
+ Set_Has_Task (T1, Has_Task (T2));
+ Set_Is_Packed (T1, Is_Packed (T2));
+ Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
+ Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
+ Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2));
+ end Copy_Array_Base_Type_Attributes;
- if No (E) then
- Derive_Subprogram
- (New_Subp, Iface_Subp, Tagged_Type, Iface);
+ -----------------------------------
+ -- Copy_Array_Subtype_Attributes --
+ -----------------------------------
- -- Ada 2012 (AI05-0197): If the covering primitive's name
- -- differs from the name of the interface primitive then it
- -- is a private primitive inherited from a parent type. In
- -- such case, given that Tagged_Type covers the interface,
- -- the inherited private primitive becomes visible. For such
- -- purpose we add a new entity that renames the inherited
- -- private primitive.
+ procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
+ begin
+ Set_Size_Info (T1, T2);
- elsif Chars (E) /= Chars (Iface_Subp) then
- pragma Assert (Has_Suffix (E, 'P'));
- Derive_Subprogram
- (New_Subp, Iface_Subp, Tagged_Type, Iface);
- Set_Alias (New_Subp, E);
- Set_Is_Abstract_Subprogram (New_Subp,
- Is_Abstract_Subprogram (E));
+ Set_First_Index (T1, First_Index (T2));
+ Set_Is_Aliased (T1, Is_Aliased (T2));
+ Set_Is_Volatile (T1, Is_Volatile (T2));
+ Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2));
+ Set_Is_Constrained (T1, Is_Constrained (T2));
+ Set_Depends_On_Private (T1, Has_Private_Component (T2));
+ Set_First_Rep_Item (T1, First_Rep_Item (T2));
+ Set_Convention (T1, Convention (T2));
+ Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
+ Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
+ Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2));
+ end Copy_Array_Subtype_Attributes;
- -- Propagate to the full view interface entities associated
- -- with the partial view.
+ -----------------------------------
+ -- Create_Constrained_Components --
+ -----------------------------------
- elsif In_Private_Part (Current_Scope)
- and then Present (Alias (E))
- and then Alias (E) = Iface_Subp
- and then
- List_Containing (Parent (E)) /=
- Private_Declarations
- (Specification
- (Unit_Declaration_Node (Current_Scope)))
- then
- Append_Elmt (E, Primitive_Operations (Tagged_Type));
- end if;
- end if;
+ procedure Create_Constrained_Components
+ (Subt : Entity_Id;
+ Decl_Node : Node_Id;
+ Typ : Entity_Id;
+ Constraints : Elist_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Subt);
+ Comp_List : constant Elist_Id := New_Elmt_List;
+ Parent_Type : constant Entity_Id := Etype (Typ);
+ Assoc_List : constant List_Id := New_List;
+ Discr_Val : Elmt_Id;
+ Errors : Boolean;
+ New_C : Entity_Id;
+ Old_C : Entity_Id;
+ Is_Static : Boolean := True;
- Next_Elmt (Prim_Elmt);
- end loop;
+ procedure Collect_Fixed_Components (Typ : Entity_Id);
+ -- Collect parent type components that do not appear in a variant part
- Next_Elmt (Iface_Elmt);
- end loop;
- end if;
- end Derive_Progenitor_Subprograms;
+ procedure Create_All_Components;
+ -- Iterate over Comp_List to create the components of the subtype
- -----------------------
- -- Derive_Subprogram --
- -----------------------
+ function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
+ -- Creates a new component from Old_Compon, copying all the fields from
+ -- it, including its Etype, inserts the new component in the Subt entity
+ -- chain and returns the new component.
- procedure Derive_Subprogram
- (New_Subp : in out Entity_Id;
- Parent_Subp : Entity_Id;
- Derived_Type : Entity_Id;
- Parent_Type : Entity_Id;
- Actual_Subp : Entity_Id := Empty)
- is
- Formal : Entity_Id;
- -- Formal parameter of parent primitive operation
+ function Is_Variant_Record (T : Entity_Id) return Boolean;
+ -- If true, and discriminants are static, collect only components from
+ -- variants selected by discriminant values.
- Formal_Of_Actual : Entity_Id;
- -- Formal parameter of actual operation, when the derivation is to
- -- create a renaming for a primitive operation of an actual in an
- -- instantiation.
+ ------------------------------
+ -- Collect_Fixed_Components --
+ ------------------------------
- New_Formal : Entity_Id;
- -- Formal of inherited operation
+ procedure Collect_Fixed_Components (Typ : Entity_Id) is
+ begin
+ -- Build association list for discriminants, and find components of the
+ -- variant part selected by the values of the discriminants.
- Visible_Subp : Entity_Id := Parent_Subp;
+ Old_C := First_Discriminant (Typ);
+ Discr_Val := First_Elmt (Constraints);
+ while Present (Old_C) loop
+ Append_To (Assoc_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (New_Occurrence_Of (Old_C, Loc)),
+ Expression => New_Copy (Node (Discr_Val))));
- function Is_Private_Overriding return Boolean;
- -- If Subp is a private overriding of a visible operation, the inherited
- -- operation derives from the overridden op (even though its body is the
- -- overriding one) and the inherited operation is visible now. See
- -- sem_disp to see the full details of the handling of the overridden
- -- subprogram, which is removed from the list of primitive operations of
- -- the type. The overridden subprogram is saved locally in Visible_Subp,
- -- and used to diagnose abstract operations that need overriding in the
- -- derived type.
+ Next_Elmt (Discr_Val);
+ Next_Discriminant (Old_C);
+ end loop;
- procedure Replace_Type (Id, New_Id : Entity_Id);
- -- When the type is an anonymous access type, create a new access type
- -- designating the derived type.
+ -- The tag and the possible parent component are unconditionally in
+ -- the subtype.
- procedure Set_Derived_Name;
- -- This procedure sets the appropriate Chars name for New_Subp. This
- -- is normally just a copy of the parent name. An exception arises for
- -- type support subprograms, where the name is changed to reflect the
- -- name of the derived type, e.g. if type foo is derived from type bar,
- -- then a procedure barDA is derived with a name fooDA.
+ if Is_Tagged_Type (Typ)
+ or else Has_Controlled_Component (Typ)
+ then
+ Old_C := First_Component (Typ);
+ while Present (Old_C) loop
+ if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then
+ Append_Elmt (Old_C, Comp_List);
+ end if;
+
+ Next_Component (Old_C);
+ end loop;
+ end if;
+ end Collect_Fixed_Components;
---------------------------
- -- Is_Private_Overriding --
+ -- Create_All_Components --
---------------------------
- function Is_Private_Overriding return Boolean is
- Prev : Entity_Id;
+ procedure Create_All_Components is
+ Comp : Elmt_Id;
begin
- -- If the parent is not a dispatching operation there is no
- -- need to investigate overridings
-
- if not Is_Dispatching_Operation (Parent_Subp) then
- return False;
- end if;
-
- -- The visible operation that is overridden is a homonym of the
- -- parent subprogram. We scan the homonym chain to find the one
- -- whose alias is the subprogram we are deriving.
+ Comp := First_Elmt (Comp_List);
+ while Present (Comp) loop
+ Old_C := Node (Comp);
+ New_C := Create_Component (Old_C);
- Prev := Current_Entity (Parent_Subp);
- while Present (Prev) loop
- if Ekind (Prev) = Ekind (Parent_Subp)
- and then Alias (Prev) = Parent_Subp
- and then Scope (Parent_Subp) = Scope (Prev)
- and then not Is_Hidden (Prev)
- then
- Visible_Subp := Prev;
- return True;
- end if;
+ Set_Etype
+ (New_C,
+ Constrain_Component_Type
+ (Old_C, Subt, Decl_Node, Typ, Constraints));
+ Set_Is_Public (New_C, Is_Public (Subt));
- Prev := Homonym (Prev);
+ Next_Elmt (Comp);
end loop;
+ end Create_All_Components;
- return False;
- end Is_Private_Overriding;
-
- ------------------
- -- Replace_Type --
- ------------------
+ ----------------------
+ -- Create_Component --
+ ----------------------
- procedure Replace_Type (Id, New_Id : Entity_Id) is
- Id_Type : constant Entity_Id := Etype (Id);
- Acc_Type : Entity_Id;
- Par : constant Node_Id := Parent (Derived_Type);
+ function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
+ New_Compon : constant Entity_Id := New_Copy (Old_Compon);
begin
- -- When the type is an anonymous access type, create a new access
- -- type designating the derived type. This itype must be elaborated
- -- at the point of the derivation, not on subsequent calls that may
- -- be out of the proper scope for Gigi, so we insert a reference to
- -- it after the derivation.
-
- if Ekind (Id_Type) = E_Anonymous_Access_Type then
- declare
- Desig_Typ : Entity_Id := Designated_Type (Id_Type);
+ if Ekind (Old_Compon) = E_Discriminant
+ and then Is_Completely_Hidden (Old_Compon)
+ then
+ -- This is a shadow discriminant created for a discriminant of
+ -- the parent type, which needs to be present in the subtype.
+ -- Give the shadow discriminant an internal name that cannot
+ -- conflict with that of visible components.
- begin
- if Ekind (Desig_Typ) = E_Record_Type_With_Private
- and then Present (Full_View (Desig_Typ))
- and then not Is_Private_Type (Parent_Type)
- then
- Desig_Typ := Full_View (Desig_Typ);
- end if;
+ Set_Chars (New_Compon, New_Internal_Name ('C'));
+ end if;
- if Base_Type (Desig_Typ) = Base_Type (Parent_Type)
+ -- Set the parent so we have a proper link for freezing etc. This is
+ -- not a real parent pointer, since of course our parent does not own
+ -- up to us and reference us, we are an illegitimate child of the
+ -- original parent.
- -- Ada 2005 (AI-251): Handle also derivations of abstract
- -- interface primitives.
+ Set_Parent (New_Compon, Parent (Old_Compon));
- or else (Is_Interface (Desig_Typ)
- and then not Is_Class_Wide_Type (Desig_Typ))
- then
- Acc_Type := New_Copy (Id_Type);
- Set_Etype (Acc_Type, Acc_Type);
- Set_Scope (Acc_Type, New_Subp);
-
- -- Set size of anonymous access type. If we have an access
- -- to an unconstrained array, this is a fat pointer, so it
- -- is sizes at twice addtress size.
+ -- If the old component's Esize was already determined and is a
+ -- static value, then the new component simply inherits it. Otherwise
+ -- the old component's size may require run-time determination, but
+ -- the new component's size still might be statically determinable
+ -- (if, for example it has a static constraint). In that case we want
+ -- Layout_Type to recompute the component's size, so we reset its
+ -- size and positional fields.
- if Is_Array_Type (Desig_Typ)
- and then not Is_Constrained (Desig_Typ)
- then
- Init_Size (Acc_Type, 2 * System_Address_Size);
+ if Frontend_Layout_On_Target
+ and then not Known_Static_Esize (Old_Compon)
+ then
+ Set_Esize (New_Compon, Uint_0);
+ Init_Normalized_First_Bit (New_Compon);
+ Init_Normalized_Position (New_Compon);
+ Init_Normalized_Position_Max (New_Compon);
+ end if;
- -- Other cases use a thin pointer
+ -- We do not want this node marked as Comes_From_Source, since
+ -- otherwise it would get first class status and a separate cross-
+ -- reference line would be generated. Illegitimate children do not
+ -- rate such recognition.
- else
- Init_Size (Acc_Type, System_Address_Size);
- end if;
+ Set_Comes_From_Source (New_Compon, False);
- -- Set remaining characterstics of anonymous access type
+ -- But it is a real entity, and a birth certificate must be properly
+ -- registered by entering it into the entity list.
- Init_Alignment (Acc_Type);
- Set_Directly_Designated_Type (Acc_Type, Derived_Type);
+ Enter_Name (New_Compon);
- Set_Etype (New_Id, Acc_Type);
- Set_Scope (New_Id, New_Subp);
+ return New_Compon;
+ end Create_Component;
- -- Create a reference to it
+ -----------------------
+ -- Is_Variant_Record --
+ -----------------------
- Build_Itype_Reference (Acc_Type, Parent (Derived_Type));
+ function Is_Variant_Record (T : Entity_Id) return Boolean is
+ begin
+ return Nkind (Parent (T)) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition
+ and then Present (Component_List (Type_Definition (Parent (T))))
+ and then
+ Present
+ (Variant_Part (Component_List (Type_Definition (Parent (T)))));
+ end Is_Variant_Record;
- else
- Set_Etype (New_Id, Id_Type);
- end if;
- end;
+ -- Start of processing for Create_Constrained_Components
- -- In Ada2012, a formal may have an incomplete type but the type
- -- derivation that inherits the primitive follows the full view.
+ begin
+ pragma Assert (Subt /= Base_Type (Subt));
+ pragma Assert (Typ = Base_Type (Typ));
- elsif Base_Type (Id_Type) = Base_Type (Parent_Type)
- or else
- (Ekind (Id_Type) = E_Record_Type_With_Private
- and then Present (Full_View (Id_Type))
- and then
- Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type))
- or else
- (Ada_Version >= Ada_2012
- and then Ekind (Id_Type) = E_Incomplete_Type
- and then Full_View (Id_Type) = Parent_Type)
- then
- -- Constraint checks on formals are generated during expansion,
- -- based on the signature of the original subprogram. The bounds
- -- of the derived type are not relevant, and thus we can use
- -- the base type for the formals. However, the return type may be
- -- used in a context that requires that the proper static bounds
- -- be used (a case statement, for example) and for those cases
- -- we must use the derived type (first subtype), not its base.
+ Set_First_Entity (Subt, Empty);
+ Set_Last_Entity (Subt, Empty);
- -- If the derived_type_definition has no constraints, we know that
- -- the derived type has the same constraints as the first subtype
- -- of the parent, and we can also use it rather than its base,
- -- which can lead to more efficient code.
+ -- Check whether constraint is fully static, in which case we can
+ -- optimize the list of components.
- if Etype (Id) = Parent_Type then
- if Is_Scalar_Type (Parent_Type)
- and then
- Subtypes_Statically_Compatible (Parent_Type, Derived_Type)
- then
- Set_Etype (New_Id, Derived_Type);
+ Discr_Val := First_Elmt (Constraints);
+ while Present (Discr_Val) loop
+ if not Is_OK_Static_Expression (Node (Discr_Val)) then
+ Is_Static := False;
+ exit;
+ end if;
- elsif Nkind (Par) = N_Full_Type_Declaration
- and then
- Nkind (Type_Definition (Par)) = N_Derived_Type_Definition
- and then
- Is_Entity_Name
- (Subtype_Indication (Type_Definition (Par)))
- then
- Set_Etype (New_Id, Derived_Type);
+ Next_Elmt (Discr_Val);
+ end loop;
- else
- Set_Etype (New_Id, Base_Type (Derived_Type));
- end if;
+ Set_Has_Static_Discriminants (Subt, Is_Static);
- else
- Set_Etype (New_Id, Base_Type (Derived_Type));
- end if;
+ Push_Scope (Subt);
- else
- Set_Etype (New_Id, Etype (Id));
- end if;
- end Replace_Type;
+ -- Inherit the discriminants of the parent type
- ----------------------
- -- Set_Derived_Name --
- ----------------------
+ Add_Discriminants : declare
+ Num_Disc : Int;
+ Num_Gird : Int;
- procedure Set_Derived_Name is
- Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp);
begin
- if Nm = TSS_Null then
- Set_Chars (New_Subp, Chars (Parent_Subp));
- else
- Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm));
- end if;
- end Set_Derived_Name;
-
- -- Start of processing for Derive_Subprogram
-
- begin
- New_Subp :=
- New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
- Set_Ekind (New_Subp, Ekind (Parent_Subp));
- Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp)));
+ Num_Disc := 0;
+ Old_C := First_Discriminant (Typ);
- -- Check whether the inherited subprogram is a private operation that
- -- should be inherited but not yet made visible. Such subprograms can
- -- become visible at a later point (e.g., the private part of a public
- -- child unit) via Declare_Inherited_Private_Subprograms. If the
- -- following predicate is true, then this is not such a private
- -- operation and the subprogram simply inherits the name of the parent
- -- subprogram. Note the special check for the names of controlled
- -- operations, which are currently exempted from being inherited with
- -- a hidden name because they must be findable for generation of
- -- implicit run-time calls.
+ while Present (Old_C) loop
+ Num_Disc := Num_Disc + 1;
+ New_C := Create_Component (Old_C);
+ Set_Is_Public (New_C, Is_Public (Subt));
+ Next_Discriminant (Old_C);
+ end loop;
- if not Is_Hidden (Parent_Subp)
- or else Is_Internal (Parent_Subp)
- or else Is_Private_Overriding
- or else Is_Internal_Name (Chars (Parent_Subp))
- or else Nam_In (Chars (Parent_Subp), Name_Initialize,
- Name_Adjust,
- Name_Finalize)
- then
- Set_Derived_Name;
+ -- For an untagged derived subtype, the number of discriminants may
+ -- be smaller than the number of inherited discriminants, because
+ -- several of them may be renamed by a single new discriminant or
+ -- constrained. In this case, add the hidden discriminants back into
+ -- the subtype, because they need to be present if the optimizer of
+ -- the GCC 4.x back-end decides to break apart assignments between
+ -- objects using the parent view into member-wise assignments.
- -- An inherited dispatching equality will be overridden by an internally
- -- generated one, or by an explicit one, so preserve its name and thus
- -- its entry in the dispatch table. Otherwise, if Parent_Subp is a
- -- private operation it may become invisible if the full view has
- -- progenitors, and the dispatch table will be malformed.
- -- We check that the type is limited to handle the anomalous declaration
- -- of Limited_Controlled, which is derived from a non-limited type, and
- -- which is handled specially elsewhere as well.
+ Num_Gird := 0;
- elsif Chars (Parent_Subp) = Name_Op_Eq
- and then Is_Dispatching_Operation (Parent_Subp)
- and then Etype (Parent_Subp) = Standard_Boolean
- and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp)))
- and then
- Etype (First_Formal (Parent_Subp)) =
- Etype (Next_Formal (First_Formal (Parent_Subp)))
- then
- Set_Derived_Name;
+ if Is_Derived_Type (Typ)
+ and then not Is_Tagged_Type (Typ)
+ then
+ Old_C := First_Stored_Discriminant (Typ);
- -- If parent is hidden, this can be a regular derivation if the
- -- parent is immediately visible in a non-instantiating context,
- -- or if we are in the private part of an instance. This test
- -- should still be refined ???
+ while Present (Old_C) loop
+ Num_Gird := Num_Gird + 1;
+ Next_Stored_Discriminant (Old_C);
+ end loop;
+ end if;
- -- The test for In_Instance_Not_Visible avoids inheriting the derived
- -- operation as a non-visible operation in cases where the parent
- -- subprogram might not be visible now, but was visible within the
- -- original generic, so it would be wrong to make the inherited
- -- subprogram non-visible now. (Not clear if this test is fully
- -- correct; are there any cases where we should declare the inherited
- -- operation as not visible to avoid it being overridden, e.g., when
- -- the parent type is a generic actual with private primitives ???)
+ if Num_Gird > Num_Disc then
- -- (they should be treated the same as other private inherited
- -- subprograms, but it's not clear how to do this cleanly). ???
+ -- Find out multiple uses of new discriminants, and add hidden
+ -- components for the extra renamed discriminants. We recognize
+ -- multiple uses through the Corresponding_Discriminant of a
+ -- new discriminant: if it constrains several old discriminants,
+ -- this field points to the last one in the parent type. The
+ -- stored discriminants of the derived type have the same name
+ -- as those of the parent.
- elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type)))
- and then Is_Immediately_Visible (Parent_Subp)
- and then not In_Instance)
- or else In_Instance_Not_Visible
- then
- Set_Derived_Name;
+ declare
+ Constr : Elmt_Id;
+ New_Discr : Entity_Id;
+ Old_Discr : Entity_Id;
- -- Ada 2005 (AI-251): Regular derivation if the parent subprogram
- -- overrides an interface primitive because interface primitives
- -- must be visible in the partial view of the parent (RM 7.3 (7.3/2))
+ begin
+ Constr := First_Elmt (Stored_Constraint (Typ));
+ Old_Discr := First_Stored_Discriminant (Typ);
+ while Present (Constr) loop
+ if Is_Entity_Name (Node (Constr))
+ and then Ekind (Entity (Node (Constr))) = E_Discriminant
+ then
+ New_Discr := Entity (Node (Constr));
- elsif Ada_Version >= Ada_2005
- and then Is_Dispatching_Operation (Parent_Subp)
- and then Covers_Some_Interface (Parent_Subp)
- then
- Set_Derived_Name;
+ if Chars (Corresponding_Discriminant (New_Discr)) /=
+ Chars (Old_Discr)
+ then
+ -- The new discriminant has been used to rename a
+ -- subsequent old discriminant. Introduce a shadow
+ -- component for the current old discriminant.
- -- Otherwise, the type is inheriting a private operation, so enter
- -- it with a special name so it can't be overridden.
+ New_C := Create_Component (Old_Discr);
+ Set_Original_Record_Component (New_C, Old_Discr);
+ end if;
- else
- Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
- end if;
+ else
+ -- The constraint has eliminated the old discriminant.
+ -- Introduce a shadow component.
- Set_Parent (New_Subp, Parent (Derived_Type));
+ New_C := Create_Component (Old_Discr);
+ Set_Original_Record_Component (New_C, Old_Discr);
+ end if;
- if Present (Actual_Subp) then
- Replace_Type (Actual_Subp, New_Subp);
- else
- Replace_Type (Parent_Subp, New_Subp);
- end if;
+ Next_Elmt (Constr);
+ Next_Stored_Discriminant (Old_Discr);
+ end loop;
+ end;
+ end if;
+ end Add_Discriminants;
- Conditional_Delay (New_Subp, Parent_Subp);
+ if Is_Static
+ and then Is_Variant_Record (Typ)
+ then
+ Collect_Fixed_Components (Typ);
- -- If we are creating a renaming for a primitive operation of an
- -- actual of a generic derived type, we must examine the signature
- -- of the actual primitive, not that of the generic formal, which for
- -- example may be an interface. However the name and initial value
- -- of the inherited operation are those of the formal primitive.
+ Gather_Components (
+ Typ,
+ Component_List (Type_Definition (Parent (Typ))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors);
+ pragma Assert (not Errors);
- Formal := First_Formal (Parent_Subp);
+ Create_All_Components;
- if Present (Actual_Subp) then
- Formal_Of_Actual := First_Formal (Actual_Subp);
- else
- Formal_Of_Actual := Empty;
- end if;
+ -- If the subtype declaration is created for a tagged type derivation
+ -- with constraints, we retrieve the record definition of the parent
+ -- type to select the components of the proper variant.
- while Present (Formal) loop
- New_Formal := New_Copy (Formal);
+ elsif Is_Static
+ and then Is_Tagged_Type (Typ)
+ and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
+ and then
+ Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition
+ and then Is_Variant_Record (Parent_Type)
+ then
+ Collect_Fixed_Components (Typ);
- -- Normally we do not go copying parents, but in the case of
- -- formals, we need to link up to the declaration (which is the
- -- parameter specification), and it is fine to link up to the
- -- original formal's parameter specification in this case.
+ Gather_Components (
+ Typ,
+ Component_List (Type_Definition (Parent (Parent_Type))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors);
+ pragma Assert (not Errors);
- Set_Parent (New_Formal, Parent (Formal));
- Append_Entity (New_Formal, New_Subp);
+ -- If the tagged derivation has a type extension, collect all the
+ -- new components therein.
- if Present (Formal_Of_Actual) then
- Replace_Type (Formal_Of_Actual, New_Formal);
- Next_Formal (Formal_Of_Actual);
- else
- Replace_Type (Formal, New_Formal);
- end if;
+ if Present
+ (Record_Extension_Part (Type_Definition (Parent (Typ))))
+ then
+ Old_C := First_Component (Typ);
+ while Present (Old_C) loop
+ if Original_Record_Component (Old_C) = Old_C
+ and then Chars (Old_C) /= Name_uTag
+ and then Chars (Old_C) /= Name_uParent
+ then
+ Append_Elmt (Old_C, Comp_List);
+ end if;
- Next_Formal (Formal);
- end loop;
+ Next_Component (Old_C);
+ end loop;
+ end if;
- -- If this derivation corresponds to a tagged generic actual, then
- -- primitive operations rename those of the actual. Otherwise the
- -- primitive operations rename those of the parent type, If the parent
- -- renames an intrinsic operator, so does the new subprogram. We except
- -- concatenation, which is always properly typed, and does not get
- -- expanded as other intrinsic operations.
+ Create_All_Components;
- if No (Actual_Subp) then
- if Is_Intrinsic_Subprogram (Parent_Subp) then
- Set_Is_Intrinsic_Subprogram (New_Subp);
+ else
+ -- If discriminants are not static, or if this is a multi-level type
+ -- extension, we have to include all components of the parent type.
- if Present (Alias (Parent_Subp))
- and then Chars (Parent_Subp) /= Name_Op_Concat
- then
- Set_Alias (New_Subp, Alias (Parent_Subp));
- else
- Set_Alias (New_Subp, Parent_Subp);
- end if;
+ Old_C := First_Component (Typ);
+ while Present (Old_C) loop
+ New_C := Create_Component (Old_C);
- else
- Set_Alias (New_Subp, Parent_Subp);
- end if;
+ Set_Etype
+ (New_C,
+ Constrain_Component_Type
+ (Old_C, Subt, Decl_Node, Typ, Constraints));
+ Set_Is_Public (New_C, Is_Public (Subt));
- else
- Set_Alias (New_Subp, Actual_Subp);
+ Next_Component (Old_C);
+ end loop;
end if;
- -- Derived subprograms of a tagged type must inherit the convention
- -- of the parent subprogram (a requirement of AI-117). Derived
- -- subprograms of untagged types simply get convention Ada by default.
+ End_Scope;
+ end Create_Constrained_Components;
- -- If the derived type is a tagged generic formal type with unknown
- -- discriminants, its convention is intrinsic (RM 6.3.1 (8)).
+ ------------------------------------------
+ -- Decimal_Fixed_Point_Type_Declaration --
+ ------------------------------------------
- -- However, if the type is derived from a generic formal, the further
- -- inherited subprogram has the convention of the non-generic ancestor.
- -- Otherwise there would be no way to override the operation.
- -- (This is subject to forthcoming ARG discussions).
+ procedure Decimal_Fixed_Point_Type_Declaration
+ (T : Entity_Id;
+ Def : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Def);
+ Digs_Expr : constant Node_Id := Digits_Expression (Def);
+ Delta_Expr : constant Node_Id := Delta_Expression (Def);
+ Implicit_Base : Entity_Id;
+ Digs_Val : Uint;
+ Delta_Val : Ureal;
+ Scale_Val : Uint;
+ Bound_Val : Ureal;
- if Is_Tagged_Type (Derived_Type) then
- if Is_Generic_Type (Derived_Type)
- and then Has_Unknown_Discriminants (Derived_Type)
- then
- Set_Convention (New_Subp, Convention_Intrinsic);
+ begin
+ Check_SPARK_05_Restriction
+ ("decimal fixed point type is not allowed", Def);
+ Check_Restriction (No_Fixed_Point, Def);
- else
- if Is_Generic_Type (Parent_Type)
- and then Has_Unknown_Discriminants (Parent_Type)
- then
- Set_Convention (New_Subp, Convention (Alias (Parent_Subp)));
- else
- Set_Convention (New_Subp, Convention (Parent_Subp));
- end if;
- end if;
- end if;
+ -- Create implicit base type
- -- Predefined controlled operations retain their name even if the parent
- -- is hidden (see above), but they are not primitive operations if the
- -- ancestor is not visible, for example if the parent is a private
- -- extension completed with a controlled extension. Note that a full
- -- type that is controlled can break privacy: the flag Is_Controlled is
- -- set on both views of the type.
+ Implicit_Base :=
+ Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
+ Set_Etype (Implicit_Base, Implicit_Base);
- if Is_Controlled (Parent_Type)
- and then Nam_In (Chars (Parent_Subp), Name_Initialize,
- Name_Adjust,
- Name_Finalize)
- and then Is_Hidden (Parent_Subp)
- and then not Is_Visibly_Controlled (Parent_Type)
- then
- Set_Is_Hidden (New_Subp);
- end if;
+ -- Analyze and process delta expression
- Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
- Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
+ Analyze_And_Resolve (Delta_Expr, Universal_Real);
- if Ekind (Parent_Subp) = E_Procedure then
- Set_Is_Valued_Procedure
- (New_Subp, Is_Valued_Procedure (Parent_Subp));
- else
- Set_Has_Controlling_Result
- (New_Subp, Has_Controlling_Result (Parent_Subp));
- end if;
+ Check_Delta_Expression (Delta_Expr);
+ Delta_Val := Expr_Value_R (Delta_Expr);
- -- No_Return must be inherited properly. If this is overridden in the
- -- case of a dispatching operation, then a check is made in Sem_Disp
- -- that the overriding operation is also No_Return (no such check is
- -- required for the case of non-dispatching operation.
+ -- Check delta is power of 10, and determine scale value from it
- Set_No_Return (New_Subp, No_Return (Parent_Subp));
+ declare
+ Val : Ureal;
- -- A derived function with a controlling result is abstract. If the
- -- Derived_Type is a nonabstract formal generic derived type, then
- -- inherited operations are not abstract: the required check is done at
- -- instantiation time. If the derivation is for a generic actual, the
- -- function is not abstract unless the actual is.
+ begin
+ Scale_Val := Uint_0;
+ Val := Delta_Val;
- if Is_Generic_Type (Derived_Type)
- and then not Is_Abstract_Type (Derived_Type)
- then
- null;
+ if Val < Ureal_1 then
+ while Val < Ureal_1 loop
+ Val := Val * Ureal_10;
+ Scale_Val := Scale_Val + 1;
+ end loop;
- -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract"
- -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2).
+ if Scale_Val > 18 then
+ Error_Msg_N ("scale exceeds maximum value of 18", Def);
+ Scale_Val := UI_From_Int (+18);
+ end if;
- elsif Ada_Version >= Ada_2005
- and then (Is_Abstract_Subprogram (Alias (New_Subp))
- or else (Is_Tagged_Type (Derived_Type)
- and then Etype (New_Subp) = Derived_Type
- and then not Is_Null_Extension (Derived_Type))
- or else (Is_Tagged_Type (Derived_Type)
- and then Ekind (Etype (New_Subp)) =
- E_Anonymous_Access_Type
- and then Designated_Type (Etype (New_Subp)) =
- Derived_Type
- and then not Is_Null_Extension (Derived_Type)))
- and then No (Actual_Subp)
- then
- if not Is_Tagged_Type (Derived_Type)
- or else Is_Abstract_Type (Derived_Type)
- or else Is_Abstract_Subprogram (Alias (New_Subp))
- then
- Set_Is_Abstract_Subprogram (New_Subp);
else
- Set_Requires_Overriding (New_Subp);
- end if;
+ while Val > Ureal_1 loop
+ Val := Val / Ureal_10;
+ Scale_Val := Scale_Val - 1;
+ end loop;
- elsif Ada_Version < Ada_2005
- and then (Is_Abstract_Subprogram (Alias (New_Subp))
- or else (Is_Tagged_Type (Derived_Type)
- and then Etype (New_Subp) = Derived_Type
- and then No (Actual_Subp)))
- then
- Set_Is_Abstract_Subprogram (New_Subp);
+ if Scale_Val < -18 then
+ Error_Msg_N ("scale is less than minimum value of -18", Def);
+ Scale_Val := UI_From_Int (-18);
+ end if;
+ end if;
- -- AI05-0097 : an inherited operation that dispatches on result is
- -- abstract if the derived type is abstract, even if the parent type
- -- is concrete and the derived type is a null extension.
+ if Val /= Ureal_1 then
+ Error_Msg_N ("delta expression must be a power of 10", Def);
+ Delta_Val := Ureal_10 ** (-Scale_Val);
+ end if;
+ end;
- elsif Has_Controlling_Result (Alias (New_Subp))
- and then Is_Abstract_Type (Etype (New_Subp))
- then
- Set_Is_Abstract_Subprogram (New_Subp);
+ -- Set delta, scale and small (small = delta for decimal type)
- -- Finally, if the parent type is abstract we must verify that all
- -- inherited operations are either non-abstract or overridden, or that
- -- the derived type itself is abstract (this check is performed at the
- -- end of a package declaration, in Check_Abstract_Overriding). A
- -- private overriding in the parent type will not be visible in the
- -- derivation if we are not in an inner package or in a child unit of
- -- the parent type, in which case the abstractness of the inherited
- -- operation is carried to the new subprogram.
+ Set_Delta_Value (Implicit_Base, Delta_Val);
+ Set_Scale_Value (Implicit_Base, Scale_Val);
+ Set_Small_Value (Implicit_Base, Delta_Val);
- elsif Is_Abstract_Type (Parent_Type)
- and then not In_Open_Scopes (Scope (Parent_Type))
- and then Is_Private_Overriding
- and then Is_Abstract_Subprogram (Visible_Subp)
- then
- if No (Actual_Subp) then
- Set_Alias (New_Subp, Visible_Subp);
- Set_Is_Abstract_Subprogram (New_Subp, True);
+ -- Analyze and process digits expression
- else
- -- If this is a derivation for an instance of a formal derived
- -- type, abstractness comes from the primitive operation of the
- -- actual, not from the operation inherited from the ancestor.
+ Analyze_And_Resolve (Digs_Expr, Any_Integer);
+ Check_Digits_Expression (Digs_Expr);
+ Digs_Val := Expr_Value (Digs_Expr);
- Set_Is_Abstract_Subprogram
- (New_Subp, Is_Abstract_Subprogram (Actual_Subp));
- end if;
+ if Digs_Val > 18 then
+ Digs_Val := UI_From_Int (+18);
+ Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr);
end if;
- New_Overloaded_Entity (New_Subp, Derived_Type);
+ Set_Digits_Value (Implicit_Base, Digs_Val);
+ Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;
- -- Check for case of a derived subprogram for the instantiation of a
- -- formal derived tagged type, if so mark the subprogram as dispatching
- -- and inherit the dispatching attributes of the actual subprogram. The
- -- derived subprogram is effectively renaming of the actual subprogram,
- -- so it needs to have the same attributes as the actual.
+ -- Set range of base type from digits value for now. This will be
+ -- expanded to represent the true underlying base range by Freeze.
- if Present (Actual_Subp)
- and then Is_Dispatching_Operation (Actual_Subp)
- then
- Set_Is_Dispatching_Operation (New_Subp);
+ Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val);
- if Present (DTC_Entity (Actual_Subp)) then
- Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
- Set_DT_Position (New_Subp, DT_Position (Actual_Subp));
- end if;
- end if;
+ -- Note: We leave size as zero for now, size will be set at freeze
+ -- time. We have to do this for ordinary fixed-point, because the size
+ -- depends on the specified small, and we might as well do the same for
+ -- decimal fixed-point.
- -- Indicate that a derived subprogram does not require a body and that
- -- it does not require processing of default expressions.
+ pragma Assert (Esize (Implicit_Base) = Uint_0);
- Set_Has_Completion (New_Subp);
- Set_Default_Expressions_Processed (New_Subp);
+ -- If there are bounds given in the declaration use them as the
+ -- bounds of the first named subtype.
- if Ekind (New_Subp) = E_Function then
- Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
- end if;
- end Derive_Subprogram;
+ if Present (Real_Range_Specification (Def)) then
+ declare
+ RRS : constant Node_Id := Real_Range_Specification (Def);
+ Low : constant Node_Id := Low_Bound (RRS);
+ High : constant Node_Id := High_Bound (RRS);
+ Low_Val : Ureal;
+ High_Val : Ureal;
- ------------------------
- -- Derive_Subprograms --
- ------------------------
+ begin
+ Analyze_And_Resolve (Low, Any_Real);
+ Analyze_And_Resolve (High, Any_Real);
+ Check_Real_Bound (Low);
+ Check_Real_Bound (High);
+ Low_Val := Expr_Value_R (Low);
+ High_Val := Expr_Value_R (High);
- procedure Derive_Subprograms
- (Parent_Type : Entity_Id;
- Derived_Type : Entity_Id;
- Generic_Actual : Entity_Id := Empty)
- is
- Op_List : constant Elist_Id :=
- Collect_Primitive_Operations (Parent_Type);
+ if Low_Val < (-Bound_Val) then
+ Error_Msg_N
+ ("range low bound too small for digits value", Low);
+ Low_Val := -Bound_Val;
+ end if;
- function Check_Derived_Type return Boolean;
- -- Check that all the entities derived from Parent_Type are found in
- -- the list of primitives of Derived_Type exactly in the same order.
+ if High_Val > Bound_Val then
+ Error_Msg_N
+ ("range high bound too large for digits value", High);
+ High_Val := Bound_Val;
+ end if;
- procedure Derive_Interface_Subprogram
- (New_Subp : in out Entity_Id;
- Subp : Entity_Id;
- Actual_Subp : Entity_Id);
- -- Derive New_Subp from the ultimate alias of the parent subprogram Subp
- -- (which is an interface primitive). If Generic_Actual is present then
- -- Actual_Subp is the actual subprogram corresponding with the generic
- -- subprogram Subp.
+ Set_Fixed_Range (T, Loc, Low_Val, High_Val);
+ end;
- function Check_Derived_Type return Boolean is
- E : Entity_Id;
- Elmt : Elmt_Id;
- List : Elist_Id;
- New_Subp : Entity_Id;
- Op_Elmt : Elmt_Id;
- Subp : Entity_Id;
+ -- If no explicit range, use range that corresponds to given
+ -- digits value. This will end up as the final range for the
+ -- first subtype.
- begin
- -- Traverse list of entities in the current scope searching for
- -- an incomplete type whose full-view is derived type
+ else
+ Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
+ end if;
- E := First_Entity (Scope (Derived_Type));
- while Present (E) and then E /= Derived_Type loop
- if Ekind (E) = E_Incomplete_Type
- and then Present (Full_View (E))
- and then Full_View (E) = Derived_Type
- then
- -- Disable this test if Derived_Type completes an incomplete
- -- type because in such case more primitives can be added
- -- later to the list of primitives of Derived_Type by routine
- -- Process_Incomplete_Dependents
+ -- Complete entity for first subtype
- return True;
- end if;
+ Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
+ Set_Size_Info (T, Implicit_Base);
+ Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+ Set_Digits_Value (T, Digs_Val);
+ Set_Delta_Value (T, Delta_Val);
+ Set_Small_Value (T, Delta_Val);
+ Set_Scale_Value (T, Scale_Val);
+ Set_Is_Constrained (T);
+ end Decimal_Fixed_Point_Type_Declaration;
- E := Next_Entity (E);
- end loop;
+ -----------------------------------
+ -- Derive_Progenitor_Subprograms --
+ -----------------------------------
- List := Collect_Primitive_Operations (Derived_Type);
- Elmt := First_Elmt (List);
+ procedure Derive_Progenitor_Subprograms
+ (Parent_Type : Entity_Id;
+ Tagged_Type : Entity_Id)
+ is
+ E : Entity_Id;
+ Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Subp : Entity_Id;
+ New_Subp : Entity_Id := Empty;
+ Prim_Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ Typ : Entity_Id;
- Op_Elmt := First_Elmt (Op_List);
- while Present (Op_Elmt) loop
- Subp := Node (Op_Elmt);
- New_Subp := Node (Elmt);
+ begin
+ pragma Assert (Ada_Version >= Ada_2005
+ and then Is_Record_Type (Tagged_Type)
+ and then Is_Tagged_Type (Tagged_Type)
+ and then Has_Interfaces (Tagged_Type));
- -- At this early stage Derived_Type has no entities with attribute
- -- Interface_Alias. In addition, such primitives are always
- -- located at the end of the list of primitives of Parent_Type.
- -- Therefore, if found we can safely stop processing pending
- -- entities.
+ -- Step 1: Transfer to the full-view primitives associated with the
+ -- partial-view that cover interface primitives. Conceptually this
+ -- work should be done later by Process_Full_View; done here to
+ -- simplify its implementation at later stages. It can be safely
+ -- done here because interfaces must be visible in the partial and
+ -- private view (RM 7.3(7.3/2)).
- exit when Present (Interface_Alias (Subp));
+ -- Small optimization: This work is only required if the parent may
+ -- have entities whose Alias attribute reference an interface primitive.
+ -- Such a situation may occur if the parent is an abstract type and the
+ -- primitive has not been yet overridden or if the parent is a generic
+ -- formal type covering interfaces.
- -- Handle hidden entities
+ -- If the tagged type is not abstract, it cannot have abstract
+ -- primitives (the only entities in the list of primitives of
+ -- non-abstract tagged types that can reference abstract primitives
+ -- through its Alias attribute are the internal entities that have
+ -- attribute Interface_Alias, and these entities are generated later
+ -- by Add_Internal_Interface_Entities).
- if not Is_Predefined_Dispatching_Operation (Subp)
- and then Is_Hidden (Subp)
- then
- if Present (New_Subp)
- and then Primitive_Names_Match (Subp, New_Subp)
- then
- Next_Elmt (Elmt);
- end if;
+ if In_Private_Part (Current_Scope)
+ and then (Is_Abstract_Type (Parent_Type)
+ or else
+ Is_Generic_Type (Parent_Type))
+ then
+ Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
- else
- if not Present (New_Subp)
- or else Ekind (Subp) /= Ekind (New_Subp)
- or else not Primitive_Names_Match (Subp, New_Subp)
+ -- At this stage it is not possible to have entities in the list
+ -- of primitives that have attribute Interface_Alias.
+
+ pragma Assert (No (Interface_Alias (Subp)));
+
+ Typ := Find_Dispatching_Type (Ultimate_Alias (Subp));
+
+ if Is_Interface (Typ) then
+ E := Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Subp);
+
+ if Present (E)
+ and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ
then
- return False;
+ Replace_Elmt (Elmt, E);
+ Remove_Homonym (Subp);
end if;
-
- Next_Elmt (Elmt);
end if;
- Next_Elmt (Op_Elmt);
+ Next_Elmt (Elmt);
end loop;
+ end if;
- return True;
- end Check_Derived_Type;
+ -- Step 2: Add primitives of progenitors that are not implemented by
+ -- parents of Tagged_Type.
- ---------------------------------
- -- Derive_Interface_Subprogram --
- ---------------------------------
+ if Present (Interfaces (Base_Type (Tagged_Type))) then
+ Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type)));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
- procedure Derive_Interface_Subprogram
- (New_Subp : in out Entity_Id;
- Subp : Entity_Id;
- Actual_Subp : Entity_Id)
- is
- Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp);
- Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp);
+ Prim_Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Prim_Elmt) loop
+ Iface_Subp := Node (Prim_Elmt);
- begin
- pragma Assert (Is_Interface (Iface_Type));
+ -- Exclude derivation of predefined primitives except those
+ -- that come from source, or are inherited from one that comes
+ -- from source. Required to catch declarations of equality
+ -- operators of interfaces. For example:
- Derive_Subprogram
- (New_Subp => New_Subp,
- Parent_Subp => Iface_Subp,
- Derived_Type => Derived_Type,
- Parent_Type => Iface_Type,
- Actual_Subp => Actual_Subp);
+ -- type Iface is interface;
+ -- function "=" (Left, Right : Iface) return Boolean;
- -- Given that this new interface entity corresponds with a primitive
- -- of the parent that was not overridden we must leave it associated
- -- with its parent primitive to ensure that it will share the same
- -- dispatch table slot when overridden.
+ if not Is_Predefined_Dispatching_Operation (Iface_Subp)
+ or else Comes_From_Source (Ultimate_Alias (Iface_Subp))
+ then
+ E := Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Iface_Subp);
- if No (Actual_Subp) then
- Set_Alias (New_Subp, Subp);
+ -- If not found we derive a new primitive leaving its alias
+ -- attribute referencing the interface primitive.
- -- For instantiations this is not needed since the previous call to
- -- Derive_Subprogram leaves the entity well decorated.
+ if No (E) then
+ Derive_Subprogram
+ (New_Subp, Iface_Subp, Tagged_Type, Iface);
- else
- pragma Assert (Alias (New_Subp) = Actual_Subp);
- null;
- end if;
- end Derive_Interface_Subprogram;
+ -- Ada 2012 (AI05-0197): If the covering primitive's name
+ -- differs from the name of the interface primitive then it
+ -- is a private primitive inherited from a parent type. In
+ -- such case, given that Tagged_Type covers the interface,
+ -- the inherited private primitive becomes visible. For such
+ -- purpose we add a new entity that renames the inherited
+ -- private primitive.
- -- Local variables
+ elsif Chars (E) /= Chars (Iface_Subp) then
+ pragma Assert (Has_Suffix (E, 'P'));
+ Derive_Subprogram
+ (New_Subp, Iface_Subp, Tagged_Type, Iface);
+ Set_Alias (New_Subp, E);
+ Set_Is_Abstract_Subprogram (New_Subp,
+ Is_Abstract_Subprogram (E));
- Alias_Subp : Entity_Id;
- Act_List : Elist_Id;
- Act_Elmt : Elmt_Id;
- Act_Subp : Entity_Id := Empty;
- Elmt : Elmt_Id;
- Need_Search : Boolean := False;
- New_Subp : Entity_Id := Empty;
- Parent_Base : Entity_Id;
- Subp : Entity_Id;
+ -- Propagate to the full view interface entities associated
+ -- with the partial view.
- -- Start of processing for Derive_Subprograms
+ elsif In_Private_Part (Current_Scope)
+ and then Present (Alias (E))
+ and then Alias (E) = Iface_Subp
+ and then
+ List_Containing (Parent (E)) /=
+ Private_Declarations
+ (Specification
+ (Unit_Declaration_Node (Current_Scope)))
+ then
+ Append_Elmt (E, Primitive_Operations (Tagged_Type));
+ end if;
+ end if;
- begin
- if Ekind (Parent_Type) = E_Record_Type_With_Private
- and then Has_Discriminants (Parent_Type)
- and then Present (Full_View (Parent_Type))
- then
- Parent_Base := Full_View (Parent_Type);
- else
- Parent_Base := Parent_Type;
- end if;
+ Next_Elmt (Prim_Elmt);
+ end loop;
- if Present (Generic_Actual) then
- Act_List := Collect_Primitive_Operations (Generic_Actual);
- Act_Elmt := First_Elmt (Act_List);
- else
- Act_List := No_Elist;
- Act_Elmt := No_Elmt;
+ Next_Elmt (Iface_Elmt);
+ end loop;
end if;
+ end Derive_Progenitor_Subprograms;
- -- Derive primitives inherited from the parent. Note that if the generic
- -- actual is present, this is not really a type derivation, it is a
- -- completion within an instance.
-
- -- Case 1: Derived_Type does not implement interfaces
+ -----------------------
+ -- Derive_Subprogram --
+ -----------------------
- if not Is_Tagged_Type (Derived_Type)
- or else (not Has_Interfaces (Derived_Type)
- and then not (Present (Generic_Actual)
- and then Has_Interfaces (Generic_Actual)))
- then
- Elmt := First_Elmt (Op_List);
- while Present (Elmt) loop
- Subp := Node (Elmt);
+ procedure Derive_Subprogram
+ (New_Subp : in out Entity_Id;
+ Parent_Subp : Entity_Id;
+ Derived_Type : Entity_Id;
+ Parent_Type : Entity_Id;
+ Actual_Subp : Entity_Id := Empty)
+ is
+ Formal : Entity_Id;
+ -- Formal parameter of parent primitive operation
- -- Literals are derived earlier in the process of building the
- -- derived type, and are skipped here.
+ Formal_Of_Actual : Entity_Id;
+ -- Formal parameter of actual operation, when the derivation is to
+ -- create a renaming for a primitive operation of an actual in an
+ -- instantiation.
- if Ekind (Subp) = E_Enumeration_Literal then
- null;
+ New_Formal : Entity_Id;
+ -- Formal of inherited operation
- -- The actual is a direct descendant and the common primitive
- -- operations appear in the same order.
+ Visible_Subp : Entity_Id := Parent_Subp;
- -- If the generic parent type is present, the derived type is an
- -- instance of a formal derived type, and within the instance its
- -- operations are those of the actual. We derive from the formal
- -- type but make the inherited operations aliases of the
- -- corresponding operations of the actual.
+ function Is_Private_Overriding return Boolean;
+ -- If Subp is a private overriding of a visible operation, the inherited
+ -- operation derives from the overridden op (even though its body is the
+ -- overriding one) and the inherited operation is visible now. See
+ -- sem_disp to see the full details of the handling of the overridden
+ -- subprogram, which is removed from the list of primitive operations of
+ -- the type. The overridden subprogram is saved locally in Visible_Subp,
+ -- and used to diagnose abstract operations that need overriding in the
+ -- derived type.
- else
- pragma Assert (No (Node (Act_Elmt))
- or else (Primitive_Names_Match (Subp, Node (Act_Elmt))
- and then
- Type_Conformant
- (Subp, Node (Act_Elmt),
- Skip_Controlling_Formals => True)));
+ procedure Replace_Type (Id, New_Id : Entity_Id);
+ -- When the type is an anonymous access type, create a new access type
+ -- designating the derived type.
- Derive_Subprogram
- (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
+ procedure Set_Derived_Name;
+ -- This procedure sets the appropriate Chars name for New_Subp. This
+ -- is normally just a copy of the parent name. An exception arises for
+ -- type support subprograms, where the name is changed to reflect the
+ -- name of the derived type, e.g. if type foo is derived from type bar,
+ -- then a procedure barDA is derived with a name fooDA.
- if Present (Act_Elmt) then
- Next_Elmt (Act_Elmt);
- end if;
- end if;
+ ---------------------------
+ -- Is_Private_Overriding --
+ ---------------------------
- Next_Elmt (Elmt);
- end loop;
+ function Is_Private_Overriding return Boolean is
+ Prev : Entity_Id;
- -- Case 2: Derived_Type implements interfaces
+ begin
+ -- If the parent is not a dispatching operation there is no
+ -- need to investigate overridings
- else
- -- If the parent type has no predefined primitives we remove
- -- predefined primitives from the list of primitives of generic
- -- actual to simplify the complexity of this algorithm.
+ if not Is_Dispatching_Operation (Parent_Subp) then
+ return False;
+ end if;
- if Present (Generic_Actual) then
- declare
- Has_Predefined_Primitives : Boolean := False;
+ -- The visible operation that is overridden is a homonym of the
+ -- parent subprogram. We scan the homonym chain to find the one
+ -- whose alias is the subprogram we are deriving.
- begin
- -- Check if the parent type has predefined primitives
-
- Elmt := First_Elmt (Op_List);
- while Present (Elmt) loop
- Subp := Node (Elmt);
-
- if Is_Predefined_Dispatching_Operation (Subp)
- and then not Comes_From_Source (Ultimate_Alias (Subp))
- then
- Has_Predefined_Primitives := True;
- exit;
- end if;
+ Prev := Current_Entity (Parent_Subp);
+ while Present (Prev) loop
+ if Ekind (Prev) = Ekind (Parent_Subp)
+ and then Alias (Prev) = Parent_Subp
+ and then Scope (Parent_Subp) = Scope (Prev)
+ and then not Is_Hidden (Prev)
+ then
+ Visible_Subp := Prev;
+ return True;
+ end if;
- Next_Elmt (Elmt);
- end loop;
+ Prev := Homonym (Prev);
+ end loop;
- -- Remove predefined primitives of Generic_Actual. We must use
- -- an auxiliary list because in case of tagged types the value
- -- returned by Collect_Primitive_Operations is the value stored
- -- in its Primitive_Operations attribute (and we don't want to
- -- modify its current contents).
+ return False;
+ end Is_Private_Overriding;
- if not Has_Predefined_Primitives then
- declare
- Aux_List : constant Elist_Id := New_Elmt_List;
+ ------------------
+ -- Replace_Type --
+ ------------------
- begin
- Elmt := First_Elmt (Act_List);
- while Present (Elmt) loop
- Subp := Node (Elmt);
+ procedure Replace_Type (Id, New_Id : Entity_Id) is
+ Id_Type : constant Entity_Id := Etype (Id);
+ Acc_Type : Entity_Id;
+ Par : constant Node_Id := Parent (Derived_Type);
- if not Is_Predefined_Dispatching_Operation (Subp)
- or else Comes_From_Source (Subp)
- then
- Append_Elmt (Subp, Aux_List);
- end if;
+ begin
+ -- When the type is an anonymous access type, create a new access
+ -- type designating the derived type. This itype must be elaborated
+ -- at the point of the derivation, not on subsequent calls that may
+ -- be out of the proper scope for Gigi, so we insert a reference to
+ -- it after the derivation.
- Next_Elmt (Elmt);
- end loop;
+ if Ekind (Id_Type) = E_Anonymous_Access_Type then
+ declare
+ Desig_Typ : Entity_Id := Designated_Type (Id_Type);
- Act_List := Aux_List;
- end;
+ begin
+ if Ekind (Desig_Typ) = E_Record_Type_With_Private
+ and then Present (Full_View (Desig_Typ))
+ and then not Is_Private_Type (Parent_Type)
+ then
+ Desig_Typ := Full_View (Desig_Typ);
end if;
- Act_Elmt := First_Elmt (Act_List);
- Act_Subp := Node (Act_Elmt);
- end;
- end if;
+ if Base_Type (Desig_Typ) = Base_Type (Parent_Type)
- -- Stage 1: If the generic actual is not present we derive the
- -- primitives inherited from the parent type. If the generic parent
- -- type is present, the derived type is an instance of a formal
- -- derived type, and within the instance its operations are those of
- -- the actual. We derive from the formal type but make the inherited
- -- operations aliases of the corresponding operations of the actual.
+ -- Ada 2005 (AI-251): Handle also derivations of abstract
+ -- interface primitives.
- Elmt := First_Elmt (Op_List);
- while Present (Elmt) loop
- Subp := Node (Elmt);
- Alias_Subp := Ultimate_Alias (Subp);
+ or else (Is_Interface (Desig_Typ)
+ and then not Is_Class_Wide_Type (Desig_Typ))
+ then
+ Acc_Type := New_Copy (Id_Type);
+ Set_Etype (Acc_Type, Acc_Type);
+ Set_Scope (Acc_Type, New_Subp);
- -- Do not derive internal entities of the parent that link
- -- interface primitives with their covering primitive. These
- -- entities will be added to this type when frozen.
+ -- Set size of anonymous access type. If we have an access
+ -- to an unconstrained array, this is a fat pointer, so it
+ -- is sizes at twice addtress size.
- if Present (Interface_Alias (Subp)) then
- goto Continue;
- end if;
+ if Is_Array_Type (Desig_Typ)
+ and then not Is_Constrained (Desig_Typ)
+ then
+ Init_Size (Acc_Type, 2 * System_Address_Size);
- -- If the generic actual is present find the corresponding
- -- operation in the generic actual. If the parent type is a
- -- direct ancestor of the derived type then, even if it is an
- -- interface, the operations are inherited from the primary
- -- dispatch table and are in the proper order. If we detect here
- -- that primitives are not in the same order we traverse the list
- -- of primitive operations of the actual to find the one that
- -- implements the interface primitive.
+ -- Other cases use a thin pointer
- if Need_Search
- or else
- (Present (Generic_Actual)
- and then Present (Act_Subp)
- and then not
- (Primitive_Names_Match (Subp, Act_Subp)
- and then
- Type_Conformant (Subp, Act_Subp,
- Skip_Controlling_Formals => True)))
- then
- pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual,
- Use_Full_View => True));
+ else
+ Init_Size (Acc_Type, System_Address_Size);
+ end if;
- -- Remember that we need searching for all pending primitives
+ -- Set remaining characterstics of anonymous access type
- Need_Search := True;
+ Init_Alignment (Acc_Type);
+ Set_Directly_Designated_Type (Acc_Type, Derived_Type);
- -- Handle entities associated with interface primitives
+ Set_Etype (New_Id, Acc_Type);
+ Set_Scope (New_Id, New_Subp);
- if Present (Alias_Subp)
- and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
- and then not Is_Predefined_Dispatching_Operation (Subp)
- then
- -- Search for the primitive in the homonym chain
+ -- Create a reference to it
- Act_Subp :=
- Find_Primitive_Covering_Interface
- (Tagged_Type => Generic_Actual,
- Iface_Prim => Alias_Subp);
+ Build_Itype_Reference (Acc_Type, Parent (Derived_Type));
- -- Previous search may not locate primitives covering
- -- interfaces defined in generics units or instantiations.
- -- (it fails if the covering primitive has formals whose
- -- type is also defined in generics or instantiations).
- -- In such case we search in the list of primitives of the
- -- generic actual for the internal entity that links the
- -- interface primitive and the covering primitive.
+ else
+ Set_Etype (New_Id, Id_Type);
+ end if;
+ end;
- if No (Act_Subp)
- and then Is_Generic_Type (Parent_Type)
- then
- -- This code has been designed to handle only generic
- -- formals that implement interfaces that are defined
- -- in a generic unit or instantiation. If this code is
- -- needed for other cases we must review it because
- -- (given that it relies on Original_Location to locate
- -- the primitive of Generic_Actual that covers the
- -- interface) it could leave linked through attribute
- -- Alias entities of unrelated instantiations).
+ -- In Ada2012, a formal may have an incomplete type but the type
+ -- derivation that inherits the primitive follows the full view.
- pragma Assert
- (Is_Generic_Unit
- (Scope (Find_Dispatching_Type (Alias_Subp)))
- or else
- Instantiation_Depth
- (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0);
+ elsif Base_Type (Id_Type) = Base_Type (Parent_Type)
+ or else
+ (Ekind (Id_Type) = E_Record_Type_With_Private
+ and then Present (Full_View (Id_Type))
+ and then
+ Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type))
+ or else
+ (Ada_Version >= Ada_2012
+ and then Ekind (Id_Type) = E_Incomplete_Type
+ and then Full_View (Id_Type) = Parent_Type)
+ then
+ -- Constraint checks on formals are generated during expansion,
+ -- based on the signature of the original subprogram. The bounds
+ -- of the derived type are not relevant, and thus we can use
+ -- the base type for the formals. However, the return type may be
+ -- used in a context that requires that the proper static bounds
+ -- be used (a case statement, for example) and for those cases
+ -- we must use the derived type (first subtype), not its base.
- declare
- Iface_Prim_Loc : constant Source_Ptr :=
- Original_Location (Sloc (Alias_Subp));
+ -- If the derived_type_definition has no constraints, we know that
+ -- the derived type has the same constraints as the first subtype
+ -- of the parent, and we can also use it rather than its base,
+ -- which can lead to more efficient code.
- Elmt : Elmt_Id;
- Prim : Entity_Id;
+ if Etype (Id) = Parent_Type then
+ if Is_Scalar_Type (Parent_Type)
+ and then
+ Subtypes_Statically_Compatible (Parent_Type, Derived_Type)
+ then
+ Set_Etype (New_Id, Derived_Type);
- begin
- Elmt :=
- First_Elmt (Primitive_Operations (Generic_Actual));
+ elsif Nkind (Par) = N_Full_Type_Declaration
+ and then
+ Nkind (Type_Definition (Par)) = N_Derived_Type_Definition
+ and then
+ Is_Entity_Name
+ (Subtype_Indication (Type_Definition (Par)))
+ then
+ Set_Etype (New_Id, Derived_Type);
- Search : while Present (Elmt) loop
- Prim := Node (Elmt);
+ else
+ Set_Etype (New_Id, Base_Type (Derived_Type));
+ end if;
- if Present (Interface_Alias (Prim))
- and then Original_Location
- (Sloc (Interface_Alias (Prim))) =
- Iface_Prim_Loc
- then
- Act_Subp := Alias (Prim);
- exit Search;
- end if;
+ else
+ Set_Etype (New_Id, Base_Type (Derived_Type));
+ end if;
- Next_Elmt (Elmt);
- end loop Search;
- end;
- end if;
+ else
+ Set_Etype (New_Id, Etype (Id));
+ end if;
+ end Replace_Type;
- pragma Assert (Present (Act_Subp)
- or else Is_Abstract_Type (Generic_Actual)
- or else Serious_Errors_Detected > 0);
+ ----------------------
+ -- Set_Derived_Name --
+ ----------------------
- -- Handle predefined primitives plus the rest of user-defined
- -- primitives
+ procedure Set_Derived_Name is
+ Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp);
+ begin
+ if Nm = TSS_Null then
+ Set_Chars (New_Subp, Chars (Parent_Subp));
+ else
+ Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm));
+ end if;
+ end Set_Derived_Name;
- else
- Act_Elmt := First_Elmt (Act_List);
- while Present (Act_Elmt) loop
- Act_Subp := Node (Act_Elmt);
+ -- Start of processing for Derive_Subprogram
- exit when Primitive_Names_Match (Subp, Act_Subp)
- and then Type_Conformant
- (Subp, Act_Subp,
- Skip_Controlling_Formals => True)
- and then No (Interface_Alias (Act_Subp));
+ begin
+ New_Subp :=
+ New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
+ Set_Ekind (New_Subp, Ekind (Parent_Subp));
+ Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp)));
- Next_Elmt (Act_Elmt);
- end loop;
+ -- Check whether the inherited subprogram is a private operation that
+ -- should be inherited but not yet made visible. Such subprograms can
+ -- become visible at a later point (e.g., the private part of a public
+ -- child unit) via Declare_Inherited_Private_Subprograms. If the
+ -- following predicate is true, then this is not such a private
+ -- operation and the subprogram simply inherits the name of the parent
+ -- subprogram. Note the special check for the names of controlled
+ -- operations, which are currently exempted from being inherited with
+ -- a hidden name because they must be findable for generation of
+ -- implicit run-time calls.
- if No (Act_Elmt) then
- Act_Subp := Empty;
- end if;
- end if;
- end if;
+ if not Is_Hidden (Parent_Subp)
+ or else Is_Internal (Parent_Subp)
+ or else Is_Private_Overriding
+ or else Is_Internal_Name (Chars (Parent_Subp))
+ or else Nam_In (Chars (Parent_Subp), Name_Initialize,
+ Name_Adjust,
+ Name_Finalize)
+ then
+ Set_Derived_Name;
- -- Case 1: If the parent is a limited interface then it has the
- -- predefined primitives of synchronized interfaces. However, the
- -- actual type may be a non-limited type and hence it does not
- -- have such primitives.
+ -- An inherited dispatching equality will be overridden by an internally
+ -- generated one, or by an explicit one, so preserve its name and thus
+ -- its entry in the dispatch table. Otherwise, if Parent_Subp is a
+ -- private operation it may become invisible if the full view has
+ -- progenitors, and the dispatch table will be malformed.
+ -- We check that the type is limited to handle the anomalous declaration
+ -- of Limited_Controlled, which is derived from a non-limited type, and
+ -- which is handled specially elsewhere as well.
- if Present (Generic_Actual)
- and then not Present (Act_Subp)
- and then Is_Limited_Interface (Parent_Base)
- and then Is_Predefined_Interface_Primitive (Subp)
+ elsif Chars (Parent_Subp) = Name_Op_Eq
+ and then Is_Dispatching_Operation (Parent_Subp)
+ and then Etype (Parent_Subp) = Standard_Boolean
+ and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp)))
+ and then
+ Etype (First_Formal (Parent_Subp)) =
+ Etype (Next_Formal (First_Formal (Parent_Subp)))
+ then
+ Set_Derived_Name;
+
+ -- If parent is hidden, this can be a regular derivation if the
+ -- parent is immediately visible in a non-instantiating context,
+ -- or if we are in the private part of an instance. This test
+ -- should still be refined ???
+
+ -- The test for In_Instance_Not_Visible avoids inheriting the derived
+ -- operation as a non-visible operation in cases where the parent
+ -- subprogram might not be visible now, but was visible within the
+ -- original generic, so it would be wrong to make the inherited
+ -- subprogram non-visible now. (Not clear if this test is fully
+ -- correct; are there any cases where we should declare the inherited
+ -- operation as not visible to avoid it being overridden, e.g., when
+ -- the parent type is a generic actual with private primitives ???)
+
+ -- (they should be treated the same as other private inherited
+ -- subprograms, but it's not clear how to do this cleanly). ???
+
+ elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type)))
+ and then Is_Immediately_Visible (Parent_Subp)
+ and then not In_Instance)
+ or else In_Instance_Not_Visible
+ then
+ Set_Derived_Name;
+
+ -- Ada 2005 (AI-251): Regular derivation if the parent subprogram
+ -- overrides an interface primitive because interface primitives
+ -- must be visible in the partial view of the parent (RM 7.3 (7.3/2))
+
+ elsif Ada_Version >= Ada_2005
+ and then Is_Dispatching_Operation (Parent_Subp)
+ and then Covers_Some_Interface (Parent_Subp)
+ then
+ Set_Derived_Name;
+
+ -- Otherwise, the type is inheriting a private operation, so enter
+ -- it with a special name so it can't be overridden.
+
+ else
+ Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
+ end if;
+
+ Set_Parent (New_Subp, Parent (Derived_Type));
+
+ if Present (Actual_Subp) then
+ Replace_Type (Actual_Subp, New_Subp);
+ else
+ Replace_Type (Parent_Subp, New_Subp);
+ end if;
+
+ Conditional_Delay (New_Subp, Parent_Subp);
+
+ -- If we are creating a renaming for a primitive operation of an
+ -- actual of a generic derived type, we must examine the signature
+ -- of the actual primitive, not that of the generic formal, which for
+ -- example may be an interface. However the name and initial value
+ -- of the inherited operation are those of the formal primitive.
+
+ Formal := First_Formal (Parent_Subp);
+
+ if Present (Actual_Subp) then
+ Formal_Of_Actual := First_Formal (Actual_Subp);
+ else
+ Formal_Of_Actual := Empty;
+ end if;
+
+ while Present (Formal) loop
+ New_Formal := New_Copy (Formal);
+
+ -- Normally we do not go copying parents, but in the case of
+ -- formals, we need to link up to the declaration (which is the
+ -- parameter specification), and it is fine to link up to the
+ -- original formal's parameter specification in this case.
+
+ Set_Parent (New_Formal, Parent (Formal));
+ Append_Entity (New_Formal, New_Subp);
+
+ if Present (Formal_Of_Actual) then
+ Replace_Type (Formal_Of_Actual, New_Formal);
+ Next_Formal (Formal_Of_Actual);
+ else
+ Replace_Type (Formal, New_Formal);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ -- If this derivation corresponds to a tagged generic actual, then
+ -- primitive operations rename those of the actual. Otherwise the
+ -- primitive operations rename those of the parent type, If the parent
+ -- renames an intrinsic operator, so does the new subprogram. We except
+ -- concatenation, which is always properly typed, and does not get
+ -- expanded as other intrinsic operations.
+
+ if No (Actual_Subp) then
+ if Is_Intrinsic_Subprogram (Parent_Subp) then
+ Set_Is_Intrinsic_Subprogram (New_Subp);
+
+ if Present (Alias (Parent_Subp))
+ and then Chars (Parent_Subp) /= Name_Op_Concat
then
- null;
+ Set_Alias (New_Subp, Alias (Parent_Subp));
+ else
+ Set_Alias (New_Subp, Parent_Subp);
+ end if;
- -- Case 2: Inherit entities associated with interfaces that were
- -- not covered by the parent type. We exclude here null interface
- -- primitives because they do not need special management.
+ else
+ Set_Alias (New_Subp, Parent_Subp);
+ end if;
- -- We also exclude interface operations that are renamings. If the
- -- subprogram is an explicit renaming of an interface primitive,
- -- it is a regular primitive operation, and the presence of its
- -- alias is not relevant: it has to be derived like any other
- -- primitive.
+ else
+ Set_Alias (New_Subp, Actual_Subp);
+ end if;
- elsif Present (Alias (Subp))
- and then Nkind (Unit_Declaration_Node (Subp)) /=
- N_Subprogram_Renaming_Declaration
- and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
- and then not
- (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification
- and then Null_Present (Parent (Alias_Subp)))
+ -- Derived subprograms of a tagged type must inherit the convention
+ -- of the parent subprogram (a requirement of AI-117). Derived
+ -- subprograms of untagged types simply get convention Ada by default.
+
+ -- If the derived type is a tagged generic formal type with unknown
+ -- discriminants, its convention is intrinsic (RM 6.3.1 (8)).
+
+ -- However, if the type is derived from a generic formal, the further
+ -- inherited subprogram has the convention of the non-generic ancestor.
+ -- Otherwise there would be no way to override the operation.
+ -- (This is subject to forthcoming ARG discussions).
+
+ if Is_Tagged_Type (Derived_Type) then
+ if Is_Generic_Type (Derived_Type)
+ and then Has_Unknown_Discriminants (Derived_Type)
+ then
+ Set_Convention (New_Subp, Convention_Intrinsic);
+
+ else
+ if Is_Generic_Type (Parent_Type)
+ and then Has_Unknown_Discriminants (Parent_Type)
then
- -- If this is an abstract private type then we transfer the
- -- derivation of the interface primitive from the partial view
- -- to the full view. This is safe because all the interfaces
- -- must be visible in the partial view. Done to avoid adding
- -- a new interface derivation to the private part of the
- -- enclosing package; otherwise this new derivation would be
- -- decorated as hidden when the analysis of the enclosing
- -- package completes.
+ Set_Convention (New_Subp, Convention (Alias (Parent_Subp)));
+ else
+ Set_Convention (New_Subp, Convention (Parent_Subp));
+ end if;
+ end if;
+ end if;
- if Is_Abstract_Type (Derived_Type)
- and then In_Private_Part (Current_Scope)
- and then Has_Private_Declaration (Derived_Type)
- then
- declare
- Partial_View : Entity_Id;
- Elmt : Elmt_Id;
- Ent : Entity_Id;
+ -- Predefined controlled operations retain their name even if the parent
+ -- is hidden (see above), but they are not primitive operations if the
+ -- ancestor is not visible, for example if the parent is a private
+ -- extension completed with a controlled extension. Note that a full
+ -- type that is controlled can break privacy: the flag Is_Controlled is
+ -- set on both views of the type.
- begin
- Partial_View := First_Entity (Current_Scope);
- loop
- exit when No (Partial_View)
- or else (Has_Private_Declaration (Partial_View)
- and then
- Full_View (Partial_View) = Derived_Type);
+ if Is_Controlled (Parent_Type)
+ and then Nam_In (Chars (Parent_Subp), Name_Initialize,
+ Name_Adjust,
+ Name_Finalize)
+ and then Is_Hidden (Parent_Subp)
+ and then not Is_Visibly_Controlled (Parent_Type)
+ then
+ Set_Is_Hidden (New_Subp);
+ end if;
- Next_Entity (Partial_View);
- end loop;
+ Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
+ Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
- -- If the partial view was not found then the source code
- -- has errors and the derivation is not needed.
+ if Ekind (Parent_Subp) = E_Procedure then
+ Set_Is_Valued_Procedure
+ (New_Subp, Is_Valued_Procedure (Parent_Subp));
+ else
+ Set_Has_Controlling_Result
+ (New_Subp, Has_Controlling_Result (Parent_Subp));
+ end if;
- if Present (Partial_View) then
- Elmt :=
- First_Elmt (Primitive_Operations (Partial_View));
- while Present (Elmt) loop
- Ent := Node (Elmt);
+ -- No_Return must be inherited properly. If this is overridden in the
+ -- case of a dispatching operation, then a check is made in Sem_Disp
+ -- that the overriding operation is also No_Return (no such check is
+ -- required for the case of non-dispatching operation.
- if Present (Alias (Ent))
- and then Ultimate_Alias (Ent) = Alias (Subp)
- then
- Append_Elmt
- (Ent, Primitive_Operations (Derived_Type));
- exit;
- end if;
+ Set_No_Return (New_Subp, No_Return (Parent_Subp));
- Next_Elmt (Elmt);
- end loop;
+ -- A derived function with a controlling result is abstract. If the
+ -- Derived_Type is a nonabstract formal generic derived type, then
+ -- inherited operations are not abstract: the required check is done at
+ -- instantiation time. If the derivation is for a generic actual, the
+ -- function is not abstract unless the actual is.
- -- If the interface primitive was not found in the
- -- partial view then this interface primitive was
- -- overridden. We add a derivation to activate in
- -- Derive_Progenitor_Subprograms the machinery to
- -- search for it.
+ if Is_Generic_Type (Derived_Type)
+ and then not Is_Abstract_Type (Derived_Type)
+ then
+ null;
- if No (Elmt) then
- Derive_Interface_Subprogram
- (New_Subp => New_Subp,
- Subp => Subp,
- Actual_Subp => Act_Subp);
- end if;
- end if;
- end;
- else
- Derive_Interface_Subprogram
- (New_Subp => New_Subp,
- Subp => Subp,
- Actual_Subp => Act_Subp);
- end if;
+ -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract"
+ -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2).
+
+ elsif Ada_Version >= Ada_2005
+ and then (Is_Abstract_Subprogram (Alias (New_Subp))
+ or else (Is_Tagged_Type (Derived_Type)
+ and then Etype (New_Subp) = Derived_Type
+ and then not Is_Null_Extension (Derived_Type))
+ or else (Is_Tagged_Type (Derived_Type)
+ and then Ekind (Etype (New_Subp)) =
+ E_Anonymous_Access_Type
+ and then Designated_Type (Etype (New_Subp)) =
+ Derived_Type
+ and then not Is_Null_Extension (Derived_Type)))
+ and then No (Actual_Subp)
+ then
+ if not Is_Tagged_Type (Derived_Type)
+ or else Is_Abstract_Type (Derived_Type)
+ or else Is_Abstract_Subprogram (Alias (New_Subp))
+ then
+ Set_Is_Abstract_Subprogram (New_Subp);
+ else
+ Set_Requires_Overriding (New_Subp);
+ end if;
- -- Case 3: Common derivation
+ elsif Ada_Version < Ada_2005
+ and then (Is_Abstract_Subprogram (Alias (New_Subp))
+ or else (Is_Tagged_Type (Derived_Type)
+ and then Etype (New_Subp) = Derived_Type
+ and then No (Actual_Subp)))
+ then
+ Set_Is_Abstract_Subprogram (New_Subp);
- else
- Derive_Subprogram
- (New_Subp => New_Subp,
- Parent_Subp => Subp,
- Derived_Type => Derived_Type,
- Parent_Type => Parent_Base,
- Actual_Subp => Act_Subp);
- end if;
+ -- AI05-0097 : an inherited operation that dispatches on result is
+ -- abstract if the derived type is abstract, even if the parent type
+ -- is concrete and the derived type is a null extension.
- -- No need to update Act_Elm if we must search for the
- -- corresponding operation in the generic actual
+ elsif Has_Controlling_Result (Alias (New_Subp))
+ and then Is_Abstract_Type (Etype (New_Subp))
+ then
+ Set_Is_Abstract_Subprogram (New_Subp);
- if not Need_Search
- and then Present (Act_Elmt)
- then
- Next_Elmt (Act_Elmt);
- Act_Subp := Node (Act_Elmt);
- end if;
+ -- Finally, if the parent type is abstract we must verify that all
+ -- inherited operations are either non-abstract or overridden, or that
+ -- the derived type itself is abstract (this check is performed at the
+ -- end of a package declaration, in Check_Abstract_Overriding). A
+ -- private overriding in the parent type will not be visible in the
+ -- derivation if we are not in an inner package or in a child unit of
+ -- the parent type, in which case the abstractness of the inherited
+ -- operation is carried to the new subprogram.
- <<Continue>>
- Next_Elmt (Elmt);
- end loop;
+ elsif Is_Abstract_Type (Parent_Type)
+ and then not In_Open_Scopes (Scope (Parent_Type))
+ and then Is_Private_Overriding
+ and then Is_Abstract_Subprogram (Visible_Subp)
+ then
+ if No (Actual_Subp) then
+ Set_Alias (New_Subp, Visible_Subp);
+ Set_Is_Abstract_Subprogram (New_Subp, True);
- -- Inherit additional operations from progenitors. If the derived
- -- type is a generic actual, there are not new primitive operations
- -- for the type because it has those of the actual, and therefore
- -- nothing needs to be done. The renamings generated above are not
- -- primitive operations, and their purpose is simply to make the
- -- proper operations visible within an instantiation.
+ else
+ -- If this is a derivation for an instance of a formal derived
+ -- type, abstractness comes from the primitive operation of the
+ -- actual, not from the operation inherited from the ancestor.
- if No (Generic_Actual) then
- Derive_Progenitor_Subprograms (Parent_Base, Derived_Type);
+ Set_Is_Abstract_Subprogram
+ (New_Subp, Is_Abstract_Subprogram (Actual_Subp));
end if;
end if;
- -- Final check: Direct descendants must have their primitives in the
- -- same order. We exclude from this test untagged types and instances
- -- of formal derived types. We skip this test if we have already
- -- reported serious errors in the sources.
+ New_Overloaded_Entity (New_Subp, Derived_Type);
- pragma Assert (not Is_Tagged_Type (Derived_Type)
- or else Present (Generic_Actual)
- or else Serious_Errors_Detected > 0
- or else Check_Derived_Type);
- end Derive_Subprograms;
+ -- Check for case of a derived subprogram for the instantiation of a
+ -- formal derived tagged type, if so mark the subprogram as dispatching
+ -- and inherit the dispatching attributes of the actual subprogram. The
+ -- derived subprogram is effectively renaming of the actual subprogram,
+ -- so it needs to have the same attributes as the actual.
- --------------------------------
- -- Derived_Standard_Character --
- --------------------------------
+ if Present (Actual_Subp)
+ and then Is_Dispatching_Operation (Actual_Subp)
+ then
+ Set_Is_Dispatching_Operation (New_Subp);
- procedure Derived_Standard_Character
- (N : Node_Id;
- Parent_Type : Entity_Id;
- Derived_Type : Entity_Id)
- is
- Loc : constant Source_Ptr := Sloc (N);
- Def : constant Node_Id := Type_Definition (N);
- Indic : constant Node_Id := Subtype_Indication (Def);
- Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
- Implicit_Base : constant Entity_Id :=
- Create_Itype
- (E_Enumeration_Type, N, Derived_Type, 'B');
+ if Present (DTC_Entity (Actual_Subp)) then
+ Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
+ Set_DT_Position (New_Subp, DT_Position (Actual_Subp));
+ end if;
+ end if;
- Lo : Node_Id;
- Hi : Node_Id;
+ -- Indicate that a derived subprogram does not require a body and that
+ -- it does not require processing of default expressions.
- begin
- Discard_Node (Process_Subtype (Indic, N));
+ Set_Has_Completion (New_Subp);
+ Set_Default_Expressions_Processed (New_Subp);
- Set_Etype (Implicit_Base, Parent_Base);
- Set_Size_Info (Implicit_Base, Root_Type (Parent_Type));
- Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type)));
+ if Ekind (New_Subp) = E_Function then
+ Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
+ end if;
+ end Derive_Subprogram;
- Set_Is_Character_Type (Implicit_Base, True);
- Set_Has_Delayed_Freeze (Implicit_Base);
+ ------------------------
+ -- Derive_Subprograms --
+ ------------------------
- -- The bounds of the implicit base are the bounds of the parent base.
- -- Note that their type is the parent base.
+ procedure Derive_Subprograms
+ (Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Generic_Actual : Entity_Id := Empty)
+ is
+ Op_List : constant Elist_Id :=
+ Collect_Primitive_Operations (Parent_Type);
- Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base));
- Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
+ function Check_Derived_Type return Boolean;
+ -- Check that all the entities derived from Parent_Type are found in
+ -- the list of primitives of Derived_Type exactly in the same order.
- Set_Scalar_Range (Implicit_Base,
- Make_Range (Loc,
- Low_Bound => Lo,
- High_Bound => Hi));
+ procedure Derive_Interface_Subprogram
+ (New_Subp : in out Entity_Id;
+ Subp : Entity_Id;
+ Actual_Subp : Entity_Id);
+ -- Derive New_Subp from the ultimate alias of the parent subprogram Subp
+ -- (which is an interface primitive). If Generic_Actual is present then
+ -- Actual_Subp is the actual subprogram corresponding with the generic
+ -- subprogram Subp.
- Conditional_Delay (Derived_Type, Parent_Type);
+ function Check_Derived_Type return Boolean is
+ E : Entity_Id;
+ Elmt : Elmt_Id;
+ List : Elist_Id;
+ New_Subp : Entity_Id;
+ Op_Elmt : Elmt_Id;
+ Subp : Entity_Id;
- Set_Ekind (Derived_Type, E_Enumeration_Subtype);
- Set_Etype (Derived_Type, Implicit_Base);
- Set_Size_Info (Derived_Type, Parent_Type);
+ begin
+ -- Traverse list of entities in the current scope searching for
+ -- an incomplete type whose full-view is derived type
- if Unknown_RM_Size (Derived_Type) then
- Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
- end if;
+ E := First_Entity (Scope (Derived_Type));
+ while Present (E) and then E /= Derived_Type loop
+ if Ekind (E) = E_Incomplete_Type
+ and then Present (Full_View (E))
+ and then Full_View (E) = Derived_Type
+ then
+ -- Disable this test if Derived_Type completes an incomplete
+ -- type because in such case more primitives can be added
+ -- later to the list of primitives of Derived_Type by routine
+ -- Process_Incomplete_Dependents
- Set_Is_Character_Type (Derived_Type, True);
+ return True;
+ end if;
- if Nkind (Indic) /= N_Subtype_Indication then
+ E := Next_Entity (E);
+ end loop;
- -- If no explicit constraint, the bounds are those
- -- of the parent type.
+ List := Collect_Primitive_Operations (Derived_Type);
+ Elmt := First_Elmt (List);
- Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type));
- Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
- Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi));
- end if;
+ Op_Elmt := First_Elmt (Op_List);
+ while Present (Op_Elmt) loop
+ Subp := Node (Op_Elmt);
+ New_Subp := Node (Elmt);
- Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
+ -- At this early stage Derived_Type has no entities with attribute
+ -- Interface_Alias. In addition, such primitives are always
+ -- located at the end of the list of primitives of Parent_Type.
+ -- Therefore, if found we can safely stop processing pending
+ -- entities.
- -- Because the implicit base is used in the conversion of the bounds, we
- -- have to freeze it now. This is similar to what is done for numeric
- -- types, and it equally suspicious, but otherwise a non-static bound
- -- will have a reference to an unfrozen type, which is rejected by Gigi
- -- (???). This requires specific care for definition of stream
- -- attributes. For details, see comments at the end of
- -- Build_Derived_Numeric_Type.
+ exit when Present (Interface_Alias (Subp));
- Freeze_Before (N, Implicit_Base);
- end Derived_Standard_Character;
+ -- Handle hidden entities
- ------------------------------
- -- Derived_Type_Declaration --
- ------------------------------
+ if not Is_Predefined_Dispatching_Operation (Subp)
+ and then Is_Hidden (Subp)
+ then
+ if Present (New_Subp)
+ and then Primitive_Names_Match (Subp, New_Subp)
+ then
+ Next_Elmt (Elmt);
+ end if;
- procedure Derived_Type_Declaration
- (T : Entity_Id;
- N : Node_Id;
- Is_Completion : Boolean)
- is
- Parent_Type : Entity_Id;
+ else
+ if not Present (New_Subp)
+ or else Ekind (Subp) /= Ekind (New_Subp)
+ or else not Primitive_Names_Match (Subp, New_Subp)
+ then
+ return False;
+ end if;
+
+ Next_Elmt (Elmt);
+ end if;
- function Comes_From_Generic (Typ : Entity_Id) return Boolean;
- -- Check whether the parent type is a generic formal, or derives
- -- directly or indirectly from one.
+ Next_Elmt (Op_Elmt);
+ end loop;
- ------------------------
- -- Comes_From_Generic --
- ------------------------
+ return True;
+ end Check_Derived_Type;
+
+ ---------------------------------
+ -- Derive_Interface_Subprogram --
+ ---------------------------------
+
+ procedure Derive_Interface_Subprogram
+ (New_Subp : in out Entity_Id;
+ Subp : Entity_Id;
+ Actual_Subp : Entity_Id)
+ is
+ Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp);
+ Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp);
- function Comes_From_Generic (Typ : Entity_Id) return Boolean is
begin
- if Is_Generic_Type (Typ) then
- return True;
+ pragma Assert (Is_Interface (Iface_Type));
- elsif Is_Generic_Type (Root_Type (Parent_Type)) then
- return True;
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Iface_Subp,
+ Derived_Type => Derived_Type,
+ Parent_Type => Iface_Type,
+ Actual_Subp => Actual_Subp);
- elsif Is_Private_Type (Typ)
- and then Present (Full_View (Typ))
- and then Is_Generic_Type (Root_Type (Full_View (Typ)))
- then
- return True;
+ -- Given that this new interface entity corresponds with a primitive
+ -- of the parent that was not overridden we must leave it associated
+ -- with its parent primitive to ensure that it will share the same
+ -- dispatch table slot when overridden.
- elsif Is_Generic_Actual_Type (Typ) then
- return True;
+ if No (Actual_Subp) then
+ Set_Alias (New_Subp, Subp);
+
+ -- For instantiations this is not needed since the previous call to
+ -- Derive_Subprogram leaves the entity well decorated.
else
- return False;
+ pragma Assert (Alias (New_Subp) = Actual_Subp);
+ null;
end if;
- end Comes_From_Generic;
+ end Derive_Interface_Subprogram;
-- Local variables
- Def : constant Node_Id := Type_Definition (N);
- Iface_Def : Node_Id;
- Indic : constant Node_Id := Subtype_Indication (Def);
- Extension : constant Node_Id := Record_Extension_Part (Def);
- Parent_Node : Node_Id;
- Taggd : Boolean;
+ Alias_Subp : Entity_Id;
+ Act_List : Elist_Id;
+ Act_Elmt : Elmt_Id;
+ Act_Subp : Entity_Id := Empty;
+ Elmt : Elmt_Id;
+ Need_Search : Boolean := False;
+ New_Subp : Entity_Id := Empty;
+ Parent_Base : Entity_Id;
+ Subp : Entity_Id;
- -- Start of processing for Derived_Type_Declaration
+ -- Start of processing for Derive_Subprograms
begin
- Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
-
- -- Ada 2005 (AI-251): In case of interface derivation check that the
- -- parent is also an interface.
-
- if Interface_Present (Def) then
- Check_SPARK_05_Restriction ("interface is not allowed", Def);
-
- if not Is_Interface (Parent_Type) then
- Diagnose_Interface (Indic, Parent_Type);
-
- else
- Parent_Node := Parent (Base_Type (Parent_Type));
- Iface_Def := Type_Definition (Parent_Node);
+ if Ekind (Parent_Type) = E_Record_Type_With_Private
+ and then Has_Discriminants (Parent_Type)
+ and then Present (Full_View (Parent_Type))
+ then
+ Parent_Base := Full_View (Parent_Type);
+ else
+ Parent_Base := Parent_Type;
+ end if;
- -- Ada 2005 (AI-251): Limited interfaces can only inherit from
- -- other limited interfaces.
+ if Present (Generic_Actual) then
+ Act_List := Collect_Primitive_Operations (Generic_Actual);
+ Act_Elmt := First_Elmt (Act_List);
+ else
+ Act_List := No_Elist;
+ Act_Elmt := No_Elmt;
+ end if;
- if Limited_Present (Def) then
- if Limited_Present (Iface_Def) then
- null;
+ -- Derive primitives inherited from the parent. Note that if the generic
+ -- actual is present, this is not really a type derivation, it is a
+ -- completion within an instance.
- elsif Protected_Present (Iface_Def) then
- Error_Msg_NE
- ("descendant of& must be declared"
- & " as a protected interface",
- N, Parent_Type);
+ -- Case 1: Derived_Type does not implement interfaces
- elsif Synchronized_Present (Iface_Def) then
- Error_Msg_NE
- ("descendant of& must be declared"
- & " as a synchronized interface",
- N, Parent_Type);
+ if not Is_Tagged_Type (Derived_Type)
+ or else (not Has_Interfaces (Derived_Type)
+ and then not (Present (Generic_Actual)
+ and then Has_Interfaces (Generic_Actual)))
+ then
+ Elmt := First_Elmt (Op_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
- elsif Task_Present (Iface_Def) then
- Error_Msg_NE
- ("descendant of& must be declared as a task interface",
- N, Parent_Type);
+ -- Literals are derived earlier in the process of building the
+ -- derived type, and are skipped here.
- else
- Error_Msg_N
- ("(Ada 2005) limited interface cannot "
- & "inherit from non-limited interface", Indic);
- end if;
+ if Ekind (Subp) = E_Enumeration_Literal then
+ null;
- -- Ada 2005 (AI-345): Non-limited interfaces can only inherit
- -- from non-limited or limited interfaces.
+ -- The actual is a direct descendant and the common primitive
+ -- operations appear in the same order.
- elsif not Protected_Present (Def)
- and then not Synchronized_Present (Def)
- and then not Task_Present (Def)
- then
- if Limited_Present (Iface_Def) then
- null;
+ -- If the generic parent type is present, the derived type is an
+ -- instance of a formal derived type, and within the instance its
+ -- operations are those of the actual. We derive from the formal
+ -- type but make the inherited operations aliases of the
+ -- corresponding operations of the actual.
- elsif Protected_Present (Iface_Def) then
- Error_Msg_NE
- ("descendant of& must be declared"
- & " as a protected interface",
- N, Parent_Type);
+ else
+ pragma Assert (No (Node (Act_Elmt))
+ or else (Primitive_Names_Match (Subp, Node (Act_Elmt))
+ and then
+ Type_Conformant
+ (Subp, Node (Act_Elmt),
+ Skip_Controlling_Formals => True)));
- elsif Synchronized_Present (Iface_Def) then
- Error_Msg_NE
- ("descendant of& must be declared"
- & " as a synchronized interface",
- N, Parent_Type);
+ Derive_Subprogram
+ (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
- elsif Task_Present (Iface_Def) then
- Error_Msg_NE
- ("descendant of& must be declared as a task interface",
- N, Parent_Type);
- else
- null;
+ if Present (Act_Elmt) then
+ Next_Elmt (Act_Elmt);
end if;
end if;
- end if;
- end if;
- if Is_Tagged_Type (Parent_Type)
- and then Is_Concurrent_Type (Parent_Type)
- and then not Is_Interface (Parent_Type)
- then
- Error_Msg_N
- ("parent type of a record extension cannot be "
- & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
- Set_Etype (T, Any_Type);
- return;
- end if;
+ Next_Elmt (Elmt);
+ end loop;
- -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
- -- interfaces
+ -- Case 2: Derived_Type implements interfaces
- if Is_Tagged_Type (Parent_Type)
- and then Is_Non_Empty_List (Interface_List (Def))
- then
- declare
- Intf : Node_Id;
- T : Entity_Id;
+ else
+ -- If the parent type has no predefined primitives we remove
+ -- predefined primitives from the list of primitives of generic
+ -- actual to simplify the complexity of this algorithm.
- begin
- Intf := First (Interface_List (Def));
- while Present (Intf) loop
- T := Find_Type_Of_Subtype_Indic (Intf);
+ if Present (Generic_Actual) then
+ declare
+ Has_Predefined_Primitives : Boolean := False;
- if not Is_Interface (T) then
- Diagnose_Interface (Intf, T);
+ begin
+ -- Check if the parent type has predefined primitives
- -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow
- -- a limited type from having a nonlimited progenitor.
+ Elmt := First_Elmt (Op_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
- elsif (Limited_Present (Def)
- or else (not Is_Interface (Parent_Type)
- and then Is_Limited_Type (Parent_Type)))
- and then not Is_Limited_Interface (T)
- then
- Error_Msg_NE
- ("progenitor interface& of limited type must be limited",
- N, T);
- end if;
+ if Is_Predefined_Dispatching_Operation (Subp)
+ and then not Comes_From_Source (Ultimate_Alias (Subp))
+ then
+ Has_Predefined_Primitives := True;
+ exit;
+ end if;
- Next (Intf);
- end loop;
- end;
- end if;
+ Next_Elmt (Elmt);
+ end loop;
- if Parent_Type = Any_Type
- or else Etype (Parent_Type) = Any_Type
- or else (Is_Class_Wide_Type (Parent_Type)
- and then Etype (Parent_Type) = T)
- then
- -- If Parent_Type is undefined or illegal, make new type into a
- -- subtype of Any_Type, and set a few attributes to prevent cascaded
- -- errors. If this is a self-definition, emit error now.
+ -- Remove predefined primitives of Generic_Actual. We must use
+ -- an auxiliary list because in case of tagged types the value
+ -- returned by Collect_Primitive_Operations is the value stored
+ -- in its Primitive_Operations attribute (and we don't want to
+ -- modify its current contents).
- if T = Parent_Type
- or else T = Etype (Parent_Type)
- then
- Error_Msg_N ("type cannot be used in its own definition", Indic);
- end if;
+ if not Has_Predefined_Primitives then
+ declare
+ Aux_List : constant Elist_Id := New_Elmt_List;
- Set_Ekind (T, Ekind (Parent_Type));
- Set_Etype (T, Any_Type);
- Set_Scalar_Range (T, Scalar_Range (Any_Type));
+ begin
+ Elmt := First_Elmt (Act_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
- if Is_Tagged_Type (T)
- and then Is_Record_Type (T)
- then
- Set_Direct_Primitive_Operations (T, New_Elmt_List);
- end if;
+ if not Is_Predefined_Dispatching_Operation (Subp)
+ or else Comes_From_Source (Subp)
+ then
+ Append_Elmt (Subp, Aux_List);
+ end if;
- return;
- end if;
+ Next_Elmt (Elmt);
+ end loop;
- -- Ada 2005 (AI-251): The case in which the parent of the full-view is
- -- an interface is special because the list of interfaces in the full
- -- view can be given in any order. For example:
+ Act_List := Aux_List;
+ end;
+ end if;
- -- type A is interface;
- -- type B is interface and A;
- -- type D is new B with private;
- -- private
- -- type D is new A and B with null record; -- 1 --
+ Act_Elmt := First_Elmt (Act_List);
+ Act_Subp := Node (Act_Elmt);
+ end;
+ end if;
- -- In this case we perform the following transformation of -1-:
+ -- Stage 1: If the generic actual is not present we derive the
+ -- primitives inherited from the parent type. If the generic parent
+ -- type is present, the derived type is an instance of a formal
+ -- derived type, and within the instance its operations are those of
+ -- the actual. We derive from the formal type but make the inherited
+ -- operations aliases of the corresponding operations of the actual.
- -- type D is new B and A with null record;
+ Elmt := First_Elmt (Op_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+ Alias_Subp := Ultimate_Alias (Subp);
- -- If the parent of the full-view covers the parent of the partial-view
- -- we have two possible cases:
+ -- Do not derive internal entities of the parent that link
+ -- interface primitives with their covering primitive. These
+ -- entities will be added to this type when frozen.
- -- 1) They have the same parent
- -- 2) The parent of the full-view implements some further interfaces
+ if Present (Interface_Alias (Subp)) then
+ goto Continue;
+ end if;
- -- In both cases we do not need to perform the transformation. In the
- -- first case the source program is correct and the transformation is
- -- not needed; in the second case the source program does not fulfill
- -- the no-hidden interfaces rule (AI-396) and the error will be reported
- -- later.
+ -- If the generic actual is present find the corresponding
+ -- operation in the generic actual. If the parent type is a
+ -- direct ancestor of the derived type then, even if it is an
+ -- interface, the operations are inherited from the primary
+ -- dispatch table and are in the proper order. If we detect here
+ -- that primitives are not in the same order we traverse the list
+ -- of primitive operations of the actual to find the one that
+ -- implements the interface primitive.
- -- This transformation not only simplifies the rest of the analysis of
- -- this type declaration but also simplifies the correct generation of
- -- the object layout to the expander.
+ if Need_Search
+ or else
+ (Present (Generic_Actual)
+ and then Present (Act_Subp)
+ and then not
+ (Primitive_Names_Match (Subp, Act_Subp)
+ and then
+ Type_Conformant (Subp, Act_Subp,
+ Skip_Controlling_Formals => True)))
+ then
+ pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual,
+ Use_Full_View => True));
- if In_Private_Part (Current_Scope)
- and then Is_Interface (Parent_Type)
- then
- declare
- Iface : Node_Id;
- Partial_View : Entity_Id;
- Partial_View_Parent : Entity_Id;
- New_Iface : Node_Id;
+ -- Remember that we need searching for all pending primitives
- begin
- -- Look for the associated private type declaration
+ Need_Search := True;
- Partial_View := First_Entity (Current_Scope);
- loop
- exit when No (Partial_View)
- or else (Has_Private_Declaration (Partial_View)
- and then Full_View (Partial_View) = T);
+ -- Handle entities associated with interface primitives
- Next_Entity (Partial_View);
- end loop;
+ if Present (Alias_Subp)
+ and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
+ and then not Is_Predefined_Dispatching_Operation (Subp)
+ then
+ -- Search for the primitive in the homonym chain
- -- If the partial view was not found then the source code has
- -- errors and the transformation is not needed.
+ Act_Subp :=
+ Find_Primitive_Covering_Interface
+ (Tagged_Type => Generic_Actual,
+ Iface_Prim => Alias_Subp);
- if Present (Partial_View) then
- Partial_View_Parent := Etype (Partial_View);
+ -- Previous search may not locate primitives covering
+ -- interfaces defined in generics units or instantiations.
+ -- (it fails if the covering primitive has formals whose
+ -- type is also defined in generics or instantiations).
+ -- In such case we search in the list of primitives of the
+ -- generic actual for the internal entity that links the
+ -- interface primitive and the covering primitive.
- -- If the parent of the full-view covers the parent of the
- -- partial-view we have nothing else to do.
+ if No (Act_Subp)
+ and then Is_Generic_Type (Parent_Type)
+ then
+ -- This code has been designed to handle only generic
+ -- formals that implement interfaces that are defined
+ -- in a generic unit or instantiation. If this code is
+ -- needed for other cases we must review it because
+ -- (given that it relies on Original_Location to locate
+ -- the primitive of Generic_Actual that covers the
+ -- interface) it could leave linked through attribute
+ -- Alias entities of unrelated instantiations).
- if Interface_Present_In_Ancestor
- (Parent_Type, Partial_View_Parent)
- then
- null;
+ pragma Assert
+ (Is_Generic_Unit
+ (Scope (Find_Dispatching_Type (Alias_Subp)))
+ or else
+ Instantiation_Depth
+ (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0);
- -- Traverse the list of interfaces of the full-view to look
- -- for the parent of the partial-view and perform the tree
- -- transformation.
+ declare
+ Iface_Prim_Loc : constant Source_Ptr :=
+ Original_Location (Sloc (Alias_Subp));
- else
- Iface := First (Interface_List (Def));
- while Present (Iface) loop
- if Etype (Iface) = Etype (Partial_View) then
- Rewrite (Subtype_Indication (Def),
- New_Copy (Subtype_Indication
- (Parent (Partial_View))));
+ Elmt : Elmt_Id;
+ Prim : Entity_Id;
- New_Iface :=
- Make_Identifier (Sloc (N), Chars (Parent_Type));
- Append (New_Iface, Interface_List (Def));
+ begin
+ Elmt :=
+ First_Elmt (Primitive_Operations (Generic_Actual));
- -- Analyze the transformed code
+ Search : while Present (Elmt) loop
+ Prim := Node (Elmt);
- Derived_Type_Declaration (T, N, Is_Completion);
- return;
- end if;
+ if Present (Interface_Alias (Prim))
+ and then Original_Location
+ (Sloc (Interface_Alias (Prim))) =
+ Iface_Prim_Loc
+ then
+ Act_Subp := Alias (Prim);
+ exit Search;
+ end if;
- Next (Iface);
- end loop;
- end if;
- end if;
- end;
- end if;
+ Next_Elmt (Elmt);
+ end loop Search;
+ end;
+ end if;
- -- Only composite types other than array types are allowed to have
- -- discriminants.
+ pragma Assert (Present (Act_Subp)
+ or else Is_Abstract_Type (Generic_Actual)
+ or else Serious_Errors_Detected > 0);
- if Present (Discriminant_Specifications (N)) then
- if (Is_Elementary_Type (Parent_Type)
- or else Is_Array_Type (Parent_Type))
- and then not Error_Posted (N)
- then
- Error_Msg_N
- ("elementary or array type cannot have discriminants",
- Defining_Identifier (First (Discriminant_Specifications (N))));
- Set_Has_Discriminants (T, False);
+ -- Handle predefined primitives plus the rest of user-defined
+ -- primitives
- -- The type is allowed to have discriminants
+ else
+ Act_Elmt := First_Elmt (Act_List);
+ while Present (Act_Elmt) loop
+ Act_Subp := Node (Act_Elmt);
- else
- Check_SPARK_05_Restriction ("discriminant type is not allowed", N);
- end if;
- end if;
+ exit when Primitive_Names_Match (Subp, Act_Subp)
+ and then Type_Conformant
+ (Subp, Act_Subp,
+ Skip_Controlling_Formals => True)
+ and then No (Interface_Alias (Act_Subp));
- -- In Ada 83, a derived type defined in a package specification cannot
- -- be used for further derivation until the end of its visible part.
- -- Note that derivation in the private part of the package is allowed.
+ Next_Elmt (Act_Elmt);
+ end loop;
- if Ada_Version = Ada_83
- and then Is_Derived_Type (Parent_Type)
- and then In_Visible_Part (Scope (Parent_Type))
- then
- if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then
- Error_Msg_N
- ("(Ada 83): premature use of type for derivation", Indic);
- end if;
- end if;
+ if No (Act_Elmt) then
+ Act_Subp := Empty;
+ end if;
+ end if;
+ end if;
- -- Check for early use of incomplete or private type
+ -- Case 1: If the parent is a limited interface then it has the
+ -- predefined primitives of synchronized interfaces. However, the
+ -- actual type may be a non-limited type and hence it does not
+ -- have such primitives.
- if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
- Error_Msg_N ("premature derivation of incomplete type", Indic);
- return;
+ if Present (Generic_Actual)
+ and then not Present (Act_Subp)
+ and then Is_Limited_Interface (Parent_Base)
+ and then Is_Predefined_Interface_Primitive (Subp)
+ then
+ null;
- elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
- and then not Comes_From_Generic (Parent_Type))
- or else Has_Private_Component (Parent_Type)
- then
- -- The ancestor type of a formal type can be incomplete, in which
- -- case only the operations of the partial view are available in the
- -- generic. Subsequent checks may be required when the full view is
- -- analyzed to verify that a derivation from a tagged type has an
- -- extension.
+ -- Case 2: Inherit entities associated with interfaces that were
+ -- not covered by the parent type. We exclude here null interface
+ -- primitives because they do not need special management.
- if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
- null;
+ -- We also exclude interface operations that are renamings. If the
+ -- subprogram is an explicit renaming of an interface primitive,
+ -- it is a regular primitive operation, and the presence of its
+ -- alias is not relevant: it has to be derived like any other
+ -- primitive.
- elsif No (Underlying_Type (Parent_Type))
- or else Has_Private_Component (Parent_Type)
- then
- Error_Msg_N
- ("premature derivation of derived or private type", Indic);
+ elsif Present (Alias (Subp))
+ and then Nkind (Unit_Declaration_Node (Subp)) /=
+ N_Subprogram_Renaming_Declaration
+ and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
+ and then not
+ (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification
+ and then Null_Present (Parent (Alias_Subp)))
+ then
+ -- If this is an abstract private type then we transfer the
+ -- derivation of the interface primitive from the partial view
+ -- to the full view. This is safe because all the interfaces
+ -- must be visible in the partial view. Done to avoid adding
+ -- a new interface derivation to the private part of the
+ -- enclosing package; otherwise this new derivation would be
+ -- decorated as hidden when the analysis of the enclosing
+ -- package completes.
- -- Flag the type itself as being in error, this prevents some
- -- nasty problems with subsequent uses of the malformed type.
+ if Is_Abstract_Type (Derived_Type)
+ and then In_Private_Part (Current_Scope)
+ and then Has_Private_Declaration (Derived_Type)
+ then
+ declare
+ Partial_View : Entity_Id;
+ Elmt : Elmt_Id;
+ Ent : Entity_Id;
- Set_Error_Posted (T);
+ begin
+ Partial_View := First_Entity (Current_Scope);
+ loop
+ exit when No (Partial_View)
+ or else (Has_Private_Declaration (Partial_View)
+ and then
+ Full_View (Partial_View) = Derived_Type);
- -- Check that within the immediate scope of an untagged partial
- -- view it's illegal to derive from the partial view if the
- -- full view is tagged. (7.3(7))
+ Next_Entity (Partial_View);
+ end loop;
- -- We verify that the Parent_Type is a partial view by checking
- -- that it is not a Full_Type_Declaration (i.e. a private type or
- -- private extension declaration), to distinguish a partial view
- -- from a derivation from a private type which also appears as
- -- E_Private_Type. If the parent base type is not declared in an
- -- enclosing scope there is no need to check.
+ -- If the partial view was not found then the source code
+ -- has errors and the derivation is not needed.
- elsif Present (Full_View (Parent_Type))
- and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration
- and then not Is_Tagged_Type (Parent_Type)
- and then Is_Tagged_Type (Full_View (Parent_Type))
- and then In_Open_Scopes (Scope (Base_Type (Parent_Type)))
- then
- Error_Msg_N
- ("premature derivation from type with tagged full view",
- Indic);
- end if;
- end if;
+ if Present (Partial_View) then
+ Elmt :=
+ First_Elmt (Primitive_Operations (Partial_View));
+ while Present (Elmt) loop
+ Ent := Node (Elmt);
- -- Check that form of derivation is appropriate
+ if Present (Alias (Ent))
+ and then Ultimate_Alias (Ent) = Alias (Subp)
+ then
+ Append_Elmt
+ (Ent, Primitive_Operations (Derived_Type));
+ exit;
+ end if;
- Taggd := Is_Tagged_Type (Parent_Type);
+ Next_Elmt (Elmt);
+ end loop;
- -- Perhaps the parent type should be changed to the class-wide type's
- -- specific type in this case to prevent cascading errors ???
+ -- If the interface primitive was not found in the
+ -- partial view then this interface primitive was
+ -- overridden. We add a derivation to activate in
+ -- Derive_Progenitor_Subprograms the machinery to
+ -- search for it.
- if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then
- Error_Msg_N ("parent type must not be a class-wide type", Indic);
- return;
- end if;
+ if No (Elmt) then
+ Derive_Interface_Subprogram
+ (New_Subp => New_Subp,
+ Subp => Subp,
+ Actual_Subp => Act_Subp);
+ end if;
+ end if;
+ end;
+ else
+ Derive_Interface_Subprogram
+ (New_Subp => New_Subp,
+ Subp => Subp,
+ Actual_Subp => Act_Subp);
+ end if;
- if Present (Extension) and then not Taggd then
- Error_Msg_N
- ("type derived from untagged type cannot have extension", Indic);
+ -- Case 3: Common derivation
- elsif No (Extension) and then Taggd then
+ else
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Subp,
+ Derived_Type => Derived_Type,
+ Parent_Type => Parent_Base,
+ Actual_Subp => Act_Subp);
+ end if;
- -- If this declaration is within a private part (or body) of a
- -- generic instantiation then the derivation is allowed (the parent
- -- type can only appear tagged in this case if it's a generic actual
- -- type, since it would otherwise have been rejected in the analysis
- -- of the generic template).
+ -- No need to update Act_Elm if we must search for the
+ -- corresponding operation in the generic actual
- if not Is_Generic_Actual_Type (Parent_Type)
- or else In_Visible_Part (Scope (Parent_Type))
- then
- if Is_Class_Wide_Type (Parent_Type) then
- Error_Msg_N
- ("parent type must not be a class-wide type", Indic);
+ if not Need_Search
+ and then Present (Act_Elmt)
+ then
+ Next_Elmt (Act_Elmt);
+ Act_Subp := Node (Act_Elmt);
+ end if;
- -- Use specific type to prevent cascaded errors.
+ <<Continue>>
+ Next_Elmt (Elmt);
+ end loop;
- Parent_Type := Etype (Parent_Type);
+ -- Inherit additional operations from progenitors. If the derived
+ -- type is a generic actual, there are not new primitive operations
+ -- for the type because it has those of the actual, and therefore
+ -- nothing needs to be done. The renamings generated above are not
+ -- primitive operations, and their purpose is simply to make the
+ -- proper operations visible within an instantiation.
- else
- Error_Msg_N
- ("type derived from tagged type must have extension", Indic);
- end if;
+ if No (Generic_Actual) then
+ Derive_Progenitor_Subprograms (Parent_Base, Derived_Type);
end if;
end if;
- -- AI-443: Synchronized formal derived types require a private
- -- extension. There is no point in checking the ancestor type or
- -- the progenitors since the construct is wrong to begin with.
+ -- Final check: Direct descendants must have their primitives in the
+ -- same order. We exclude from this test untagged types and instances
+ -- of formal derived types. We skip this test if we have already
+ -- reported serious errors in the sources.
- if Ada_Version >= Ada_2005
- and then Is_Generic_Type (T)
- and then Present (Original_Node (N))
- then
- declare
- Decl : constant Node_Id := Original_Node (N);
+ pragma Assert (not Is_Tagged_Type (Derived_Type)
+ or else Present (Generic_Actual)
+ or else Serious_Errors_Detected > 0
+ or else Check_Derived_Type);
+ end Derive_Subprograms;
- begin
- if Nkind (Decl) = N_Formal_Type_Declaration
- and then Nkind (Formal_Type_Definition (Decl)) =
- N_Formal_Derived_Type_Definition
- and then Synchronized_Present (Formal_Type_Definition (Decl))
- and then No (Extension)
+ --------------------------------
+ -- Derived_Standard_Character --
+ --------------------------------
- -- Avoid emitting a duplicate error message
+ procedure Derived_Standard_Character
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Def : constant Node_Id := Type_Definition (N);
+ Indic : constant Node_Id := Subtype_Indication (Def);
+ Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
+ Implicit_Base : constant Entity_Id :=
+ Create_Itype
+ (E_Enumeration_Type, N, Derived_Type, 'B');
- and then not Error_Posted (Indic)
- then
- Error_Msg_N
- ("synchronized derived type must have extension", N);
- end if;
- end;
- end if;
+ Lo : Node_Id;
+ Hi : Node_Id;
- if Null_Exclusion_Present (Def)
- and then not Is_Access_Type (Parent_Type)
- then
- Error_Msg_N ("null exclusion can only apply to an access type", N);
- end if;
+ begin
+ Discard_Node (Process_Subtype (Indic, N));
- -- Avoid deriving parent primitives of underlying record views
+ Set_Etype (Implicit_Base, Parent_Base);
+ Set_Size_Info (Implicit_Base, Root_Type (Parent_Type));
+ Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type)));
- Build_Derived_Type (N, Parent_Type, T, Is_Completion,
- Derive_Subps => not Is_Underlying_Record_View (T));
+ Set_Is_Character_Type (Implicit_Base, True);
+ Set_Has_Delayed_Freeze (Implicit_Base);
- -- AI-419: The parent type of an explicitly limited derived type must
- -- be a limited type or a limited interface.
+ -- The bounds of the implicit base are the bounds of the parent base.
+ -- Note that their type is the parent base.
- if Limited_Present (Def) then
- Set_Is_Limited_Record (T);
+ Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base));
+ Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
- if Is_Interface (T) then
- Set_Is_Limited_Interface (T);
- end if;
+ Set_Scalar_Range (Implicit_Base,
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi));
- if not Is_Limited_Type (Parent_Type)
- and then
- (not Is_Interface (Parent_Type)
- or else not Is_Limited_Interface (Parent_Type))
- then
- -- AI05-0096: a derivation in the private part of an instance is
- -- legal if the generic formal is untagged limited, and the actual
- -- is non-limited.
+ Conditional_Delay (Derived_Type, Parent_Type);
- if Is_Generic_Actual_Type (Parent_Type)
- and then In_Private_Part (Current_Scope)
- and then
- not Is_Tagged_Type
- (Generic_Parent_Type (Parent (Parent_Type)))
- then
- null;
+ Set_Ekind (Derived_Type, E_Enumeration_Subtype);
+ Set_Etype (Derived_Type, Implicit_Base);
+ Set_Size_Info (Derived_Type, Parent_Type);
- else
- Error_Msg_NE
- ("parent type& of limited type must be limited",
- N, Parent_Type);
- end if;
- end if;
+ if Unknown_RM_Size (Derived_Type) then
+ Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
end if;
- -- In SPARK, there are no derived type definitions other than type
- -- extensions of tagged record types.
+ Set_Is_Character_Type (Derived_Type, True);
- if No (Extension) then
- Check_SPARK_05_Restriction
- ("derived type is not allowed", Original_Node (N));
- end if;
- end Derived_Type_Declaration;
+ if Nkind (Indic) /= N_Subtype_Indication then
- ------------------------
- -- Diagnose_Interface --
- ------------------------
+ -- If no explicit constraint, the bounds are those
+ -- of the parent type.
- procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is
- begin
- if not Is_Interface (E)
- and then E /= Any_Type
- then
- Error_Msg_NE ("(Ada 2005) & must be an interface", N, E);
+ Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type));
+ Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
+ Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi));
end if;
- end Diagnose_Interface;
-
- ----------------------------------
- -- Enumeration_Type_Declaration --
- ----------------------------------
- procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is
- Ev : Uint;
- L : Node_Id;
- R_Node : Node_Id;
- B_Node : Node_Id;
+ Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
- begin
- -- Create identifier node representing lower bound
+ -- Because the implicit base is used in the conversion of the bounds, we
+ -- have to freeze it now. This is similar to what is done for numeric
+ -- types, and it equally suspicious, but otherwise a non-static bound
+ -- will have a reference to an unfrozen type, which is rejected by Gigi
+ -- (???). This requires specific care for definition of stream
+ -- attributes. For details, see comments at the end of
+ -- Build_Derived_Numeric_Type.
- B_Node := New_Node (N_Identifier, Sloc (Def));
- L := First (Literals (Def));
- Set_Chars (B_Node, Chars (L));
- Set_Entity (B_Node, L);
- Set_Etype (B_Node, T);
- Set_Is_Static_Expression (B_Node, True);
+ Freeze_Before (N, Implicit_Base);
+ end Derived_Standard_Character;
- R_Node := New_Node (N_Range, Sloc (Def));
- Set_Low_Bound (R_Node, B_Node);
+ ------------------------------
+ -- Derived_Type_Declaration --
+ ------------------------------
- Set_Ekind (T, E_Enumeration_Type);
- Set_First_Literal (T, L);
- Set_Etype (T, T);
- Set_Is_Constrained (T);
+ procedure Derived_Type_Declaration
+ (T : Entity_Id;
+ N : Node_Id;
+ Is_Completion : Boolean)
+ is
+ Parent_Type : Entity_Id;
- Ev := Uint_0;
+ function Comes_From_Generic (Typ : Entity_Id) return Boolean;
+ -- Check whether the parent type is a generic formal, or derives
+ -- directly or indirectly from one.
- -- Loop through literals of enumeration type setting pos and rep values
- -- except that if the Ekind is already set, then it means the literal
- -- was already constructed (case of a derived type declaration and we
- -- should not disturb the Pos and Rep values.
+ ------------------------
+ -- Comes_From_Generic --
+ ------------------------
- while Present (L) loop
- if Ekind (L) /= E_Enumeration_Literal then
- Set_Ekind (L, E_Enumeration_Literal);
- Set_Enumeration_Pos (L, Ev);
- Set_Enumeration_Rep (L, Ev);
- Set_Is_Known_Valid (L, True);
- end if;
+ function Comes_From_Generic (Typ : Entity_Id) return Boolean is
+ begin
+ if Is_Generic_Type (Typ) then
+ return True;
- Set_Etype (L, T);
- New_Overloaded_Entity (L);
- Generate_Definition (L);
- Set_Convention (L, Convention_Intrinsic);
+ elsif Is_Generic_Type (Root_Type (Parent_Type)) then
+ return True;
- -- Case of character literal
+ elsif Is_Private_Type (Typ)
+ and then Present (Full_View (Typ))
+ and then Is_Generic_Type (Root_Type (Full_View (Typ)))
+ then
+ return True;
- if Nkind (L) = N_Defining_Character_Literal then
- Set_Is_Character_Type (T, True);
+ elsif Is_Generic_Actual_Type (Typ) then
+ return True;
- -- Check violation of No_Wide_Characters
+ else
+ return False;
+ end if;
+ end Comes_From_Generic;
- if Restriction_Check_Required (No_Wide_Characters) then
- Get_Name_String (Chars (L));
+ -- Local variables
- if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then
- Check_Restriction (No_Wide_Characters, L);
- end if;
- end if;
- end if;
+ Def : constant Node_Id := Type_Definition (N);
+ Iface_Def : Node_Id;
+ Indic : constant Node_Id := Subtype_Indication (Def);
+ Extension : constant Node_Id := Record_Extension_Part (Def);
+ Parent_Node : Node_Id;
+ Taggd : Boolean;
- Ev := Ev + 1;
- Next (L);
- end loop;
+ -- Start of processing for Derived_Type_Declaration
- -- Now create a node representing upper bound
+ begin
+ Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
- B_Node := New_Node (N_Identifier, Sloc (Def));
- Set_Chars (B_Node, Chars (Last (Literals (Def))));
- Set_Entity (B_Node, Last (Literals (Def)));
- Set_Etype (B_Node, T);
- Set_Is_Static_Expression (B_Node, True);
+ -- Ada 2005 (AI-251): In case of interface derivation check that the
+ -- parent is also an interface.
- Set_High_Bound (R_Node, B_Node);
+ if Interface_Present (Def) then
+ Check_SPARK_05_Restriction ("interface is not allowed", Def);
- -- Initialize various fields of the type. Some of this information
- -- may be overwritten later through rep.clauses.
+ if not Is_Interface (Parent_Type) then
+ Diagnose_Interface (Indic, Parent_Type);
- Set_Scalar_Range (T, R_Node);
- Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
- Set_Enum_Esize (T);
- Set_Enum_Pos_To_Rep (T, Empty);
+ else
+ Parent_Node := Parent (Base_Type (Parent_Type));
+ Iface_Def := Type_Definition (Parent_Node);
- -- Set Discard_Names if configuration pragma set, or if there is
- -- a parameterless pragma in the current declarative region
+ -- Ada 2005 (AI-251): Limited interfaces can only inherit from
+ -- other limited interfaces.
- if Global_Discard_Names or else Discard_Names (Scope (T)) then
- Set_Discard_Names (T);
- end if;
+ if Limited_Present (Def) then
+ if Limited_Present (Iface_Def) then
+ null;
- -- Process end label if there is one
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_NE
+ ("descendant of& must be declared"
+ & " as a protected interface",
+ N, Parent_Type);
- if Present (Def) then
- Process_End_Label (Def, 'e', T);
- end if;
- end Enumeration_Type_Declaration;
+ elsif Synchronized_Present (Iface_Def) then
+ Error_Msg_NE
+ ("descendant of& must be declared"
+ & " as a synchronized interface",
+ N, Parent_Type);
- ---------------------------------
- -- Expand_To_Stored_Constraint --
- ---------------------------------
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_NE
+ ("descendant of& must be declared as a task interface",
+ N, Parent_Type);
- function Expand_To_Stored_Constraint
- (Typ : Entity_Id;
- Constraint : Elist_Id) return Elist_Id
- is
- Explicitly_Discriminated_Type : Entity_Id;
- Expansion : Elist_Id;
- Discriminant : Entity_Id;
+ else
+ Error_Msg_N
+ ("(Ada 2005) limited interface cannot "
+ & "inherit from non-limited interface", Indic);
+ end if;
- function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
- -- Find the nearest type that actually specifies discriminants
+ -- Ada 2005 (AI-345): Non-limited interfaces can only inherit
+ -- from non-limited or limited interfaces.
- ---------------------------------
- -- Type_With_Explicit_Discrims --
- ---------------------------------
+ elsif not Protected_Present (Def)
+ and then not Synchronized_Present (Def)
+ and then not Task_Present (Def)
+ then
+ if Limited_Present (Iface_Def) then
+ null;
- function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is
- Typ : constant E := Base_Type (Id);
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_NE
+ ("descendant of& must be declared"
+ & " as a protected interface",
+ N, Parent_Type);
- begin
- if Ekind (Typ) in Incomplete_Or_Private_Kind then
- if Present (Full_View (Typ)) then
- return Type_With_Explicit_Discrims (Full_View (Typ));
- end if;
+ elsif Synchronized_Present (Iface_Def) then
+ Error_Msg_NE
+ ("descendant of& must be declared"
+ & " as a synchronized interface",
+ N, Parent_Type);
- else
- if Has_Discriminants (Typ) then
- return Typ;
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_NE
+ ("descendant of& must be declared as a task interface",
+ N, Parent_Type);
+ else
+ null;
+ end if;
end if;
end if;
+ end if;
- if Etype (Typ) = Typ then
- return Empty;
- elsif Has_Discriminants (Typ) then
- return Typ;
- else
- return Type_With_Explicit_Discrims (Etype (Typ));
- end if;
-
- end Type_With_Explicit_Discrims;
+ if Is_Tagged_Type (Parent_Type)
+ and then Is_Concurrent_Type (Parent_Type)
+ and then not Is_Interface (Parent_Type)
+ then
+ Error_Msg_N
+ ("parent type of a record extension cannot be "
+ & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
+ Set_Etype (T, Any_Type);
+ return;
+ end if;
- -- Start of processing for Expand_To_Stored_Constraint
+ -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
+ -- interfaces
- begin
- if No (Constraint)
- or else Is_Empty_Elmt_List (Constraint)
+ if Is_Tagged_Type (Parent_Type)
+ and then Is_Non_Empty_List (Interface_List (Def))
then
- return No_Elist;
- end if;
+ declare
+ Intf : Node_Id;
+ T : Entity_Id;
- Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ);
+ begin
+ Intf := First (Interface_List (Def));
+ while Present (Intf) loop
+ T := Find_Type_Of_Subtype_Indic (Intf);
- if No (Explicitly_Discriminated_Type) then
- return No_Elist;
- end if;
+ if not Is_Interface (T) then
+ Diagnose_Interface (Intf, T);
- Expansion := New_Elmt_List;
+ -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow
+ -- a limited type from having a nonlimited progenitor.
- Discriminant :=
- First_Stored_Discriminant (Explicitly_Discriminated_Type);
- while Present (Discriminant) loop
- Append_Elmt
- (Get_Discriminant_Value
- (Discriminant, Explicitly_Discriminated_Type, Constraint),
- To => Expansion);
- Next_Stored_Discriminant (Discriminant);
- end loop;
+ elsif (Limited_Present (Def)
+ or else (not Is_Interface (Parent_Type)
+ and then Is_Limited_Type (Parent_Type)))
+ and then not Is_Limited_Interface (T)
+ then
+ Error_Msg_NE
+ ("progenitor interface& of limited type must be limited",
+ N, T);
+ end if;
- return Expansion;
- end Expand_To_Stored_Constraint;
+ Next (Intf);
+ end loop;
+ end;
+ end if;
- ---------------------------
- -- Find_Hidden_Interface --
- ---------------------------
+ if Parent_Type = Any_Type
+ or else Etype (Parent_Type) = Any_Type
+ or else (Is_Class_Wide_Type (Parent_Type)
+ and then Etype (Parent_Type) = T)
+ then
+ -- If Parent_Type is undefined or illegal, make new type into a
+ -- subtype of Any_Type, and set a few attributes to prevent cascaded
+ -- errors. If this is a self-definition, emit error now.
- function Find_Hidden_Interface
- (Src : Elist_Id;
- Dest : Elist_Id) return Entity_Id
- is
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
+ if T = Parent_Type
+ or else T = Etype (Parent_Type)
+ then
+ Error_Msg_N ("type cannot be used in its own definition", Indic);
+ end if;
- begin
- if Present (Src) and then Present (Dest) then
- Iface_Elmt := First_Elmt (Src);
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
+ Set_Ekind (T, Ekind (Parent_Type));
+ Set_Etype (T, Any_Type);
+ Set_Scalar_Range (T, Scalar_Range (Any_Type));
- if Is_Interface (Iface)
- and then not Contain_Interface (Iface, Dest)
- then
- return Iface;
- end if;
+ if Is_Tagged_Type (T)
+ and then Is_Record_Type (T)
+ then
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+ end if;
- Next_Elmt (Iface_Elmt);
- end loop;
+ return;
end if;
- return Empty;
- end Find_Hidden_Interface;
+ -- Ada 2005 (AI-251): The case in which the parent of the full-view is
+ -- an interface is special because the list of interfaces in the full
+ -- view can be given in any order. For example:
- --------------------
- -- Find_Type_Name --
- --------------------
+ -- type A is interface;
+ -- type B is interface and A;
+ -- type D is new B with private;
+ -- private
+ -- type D is new A and B with null record; -- 1 --
- function Find_Type_Name (N : Node_Id) return Entity_Id is
- Id : constant Entity_Id := Defining_Identifier (N);
- Prev : Entity_Id;
- New_Id : Entity_Id;
- Prev_Par : Node_Id;
+ -- In this case we perform the following transformation of -1-:
- procedure Check_Duplicate_Aspects;
- -- Check that aspects specified in a completion have not been specified
- -- already in the partial view. Type_Invariant and others can be
- -- specified on either view but never on both.
+ -- type D is new B and A with null record;
- procedure Tag_Mismatch;
- -- Diagnose a tagged partial view whose full view is untagged.
- -- We post the message on the full view, with a reference to
- -- the previous partial view. The partial view can be private
- -- or incomplete, and these are handled in a different manner,
- -- so we determine the position of the error message from the
- -- respective slocs of both.
+ -- If the parent of the full-view covers the parent of the partial-view
+ -- we have two possible cases:
- -----------------------------
- -- Check_Duplicate_Aspects --
- -----------------------------
- procedure Check_Duplicate_Aspects is
- Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par);
- Full_Aspects : constant List_Id := Aspect_Specifications (N);
- F_Spec, P_Spec : Node_Id;
+ -- 1) They have the same parent
+ -- 2) The parent of the full-view implements some further interfaces
- begin
- if Present (Prev_Aspects) and then Present (Full_Aspects) then
- F_Spec := First (Full_Aspects);
- while Present (F_Spec) loop
- P_Spec := First (Prev_Aspects);
- while Present (P_Spec) loop
- if
- Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec))
- then
- Error_Msg_N
- ("aspect already specified in private declaration",
- F_Spec);
- Remove (F_Spec);
- return;
- end if;
+ -- In both cases we do not need to perform the transformation. In the
+ -- first case the source program is correct and the transformation is
+ -- not needed; in the second case the source program does not fulfill
+ -- the no-hidden interfaces rule (AI-396) and the error will be reported
+ -- later.
- Next (P_Spec);
- end loop;
+ -- This transformation not only simplifies the rest of the analysis of
+ -- this type declaration but also simplifies the correct generation of
+ -- the object layout to the expander.
- Next (F_Spec);
- end loop;
- end if;
- end Check_Duplicate_Aspects;
+ if In_Private_Part (Current_Scope)
+ and then Is_Interface (Parent_Type)
+ then
+ declare
+ Iface : Node_Id;
+ Partial_View : Entity_Id;
+ Partial_View_Parent : Entity_Id;
+ New_Iface : Node_Id;
- ------------------
- -- Tag_Mismatch --
- ------------------
+ begin
+ -- Look for the associated private type declaration
- procedure Tag_Mismatch is
- begin
- if Sloc (Prev) < Sloc (Id) then
- if Ada_Version >= Ada_2012
- and then Nkind (N) = N_Private_Type_Declaration
- then
- Error_Msg_NE
- ("declaration of private } must be a tagged type ", Id, Prev);
- else
- Error_Msg_NE
- ("full declaration of } must be a tagged type ", Id, Prev);
- end if;
+ Partial_View := First_Entity (Current_Scope);
+ loop
+ exit when No (Partial_View)
+ or else (Has_Private_Declaration (Partial_View)
+ and then Full_View (Partial_View) = T);
- else
- if Ada_Version >= Ada_2012
- and then Nkind (N) = N_Private_Type_Declaration
- then
- Error_Msg_NE
- ("declaration of private } must be a tagged type ", Prev, Id);
- else
- Error_Msg_NE
- ("full declaration of } must be a tagged type ", Prev, Id);
- end if;
- end if;
- end Tag_Mismatch;
+ Next_Entity (Partial_View);
+ end loop;
- -- Start of processing for Find_Type_Name
+ -- If the partial view was not found then the source code has
+ -- errors and the transformation is not needed.
- begin
- -- Find incomplete declaration, if one was given
+ if Present (Partial_View) then
+ Partial_View_Parent := Etype (Partial_View);
- Prev := Current_Entity_In_Scope (Id);
+ -- If the parent of the full-view covers the parent of the
+ -- partial-view we have nothing else to do.
+
+ if Interface_Present_In_Ancestor
+ (Parent_Type, Partial_View_Parent)
+ then
+ null;
- -- New type declaration
+ -- Traverse the list of interfaces of the full-view to look
+ -- for the parent of the partial-view and perform the tree
+ -- transformation.
- if No (Prev) then
- Enter_Name (Id);
- return Id;
+ else
+ Iface := First (Interface_List (Def));
+ while Present (Iface) loop
+ if Etype (Iface) = Etype (Partial_View) then
+ Rewrite (Subtype_Indication (Def),
+ New_Copy (Subtype_Indication
+ (Parent (Partial_View))));
- -- Previous declaration exists
+ New_Iface :=
+ Make_Identifier (Sloc (N), Chars (Parent_Type));
+ Append (New_Iface, Interface_List (Def));
- else
- Prev_Par := Parent (Prev);
+ -- Analyze the transformed code
- -- Error if not incomplete/private case except if previous
- -- declaration is implicit, etc. Enter_Name will emit error if
- -- appropriate.
+ Derived_Type_Declaration (T, N, Is_Completion);
+ return;
+ end if;
- if not Is_Incomplete_Or_Private_Type (Prev) then
- Enter_Name (Id);
- New_Id := Id;
+ Next (Iface);
+ end loop;
+ end if;
+ end if;
+ end;
+ end if;
- -- Check invalid completion of private or incomplete type
+ -- Only composite types other than array types are allowed to have
+ -- discriminants.
- elsif not Nkind_In (N, N_Full_Type_Declaration,
- N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
- and then
- (Ada_Version < Ada_2012
- or else not Is_Incomplete_Type (Prev)
- or else not Nkind_In (N, N_Private_Type_Declaration,
- N_Private_Extension_Declaration))
+ if Present (Discriminant_Specifications (N)) then
+ if (Is_Elementary_Type (Parent_Type)
+ or else Is_Array_Type (Parent_Type))
+ and then not Error_Posted (N)
then
- -- Completion must be a full type declarations (RM 7.3(4))
+ Error_Msg_N
+ ("elementary or array type cannot have discriminants",
+ Defining_Identifier (First (Discriminant_Specifications (N))));
+ Set_Has_Discriminants (T, False);
- Error_Msg_Sloc := Sloc (Prev);
- Error_Msg_NE ("invalid completion of }", Id, Prev);
+ -- The type is allowed to have discriminants
- -- Set scope of Id to avoid cascaded errors. Entity is never
- -- examined again, except when saving globals in generics.
+ else
+ Check_SPARK_05_Restriction ("discriminant type is not allowed", N);
+ end if;
+ end if;
- Set_Scope (Id, Current_Scope);
- New_Id := Id;
+ -- In Ada 83, a derived type defined in a package specification cannot
+ -- be used for further derivation until the end of its visible part.
+ -- Note that derivation in the private part of the package is allowed.
- -- If this is a repeated incomplete declaration, no further
- -- checks are possible.
+ if Ada_Version = Ada_83
+ and then Is_Derived_Type (Parent_Type)
+ and then In_Visible_Part (Scope (Parent_Type))
+ then
+ if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then
+ Error_Msg_N
+ ("(Ada 83): premature use of type for derivation", Indic);
+ end if;
+ end if;
- if Nkind (N) = N_Incomplete_Type_Declaration then
- return Prev;
- end if;
+ -- Check for early use of incomplete or private type
- -- Case of full declaration of incomplete type
+ if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then
+ Error_Msg_N ("premature derivation of incomplete type", Indic);
+ return;
- elsif Ekind (Prev) = E_Incomplete_Type
- and then (Ada_Version < Ada_2012
- or else No (Full_View (Prev))
- or else not Is_Private_Type (Full_View (Prev)))
+ elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
+ and then not Comes_From_Generic (Parent_Type))
+ or else Has_Private_Component (Parent_Type)
+ then
+ -- The ancestor type of a formal type can be incomplete, in which
+ -- case only the operations of the partial view are available in the
+ -- generic. Subsequent checks may be required when the full view is
+ -- analyzed to verify that a derivation from a tagged type has an
+ -- extension.
+
+ if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
+ null;
+
+ elsif No (Underlying_Type (Parent_Type))
+ or else Has_Private_Component (Parent_Type)
then
- -- Indicate that the incomplete declaration has a matching full
- -- declaration. The defining occurrence of the incomplete
- -- declaration remains the visible one, and the procedure
- -- Get_Full_View dereferences it whenever the type is used.
+ Error_Msg_N
+ ("premature derivation of derived or private type", Indic);
- if Present (Full_View (Prev)) then
- Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
- end if;
+ -- Flag the type itself as being in error, this prevents some
+ -- nasty problems with subsequent uses of the malformed type.
- Set_Full_View (Prev, Id);
- Append_Entity (Id, Current_Scope);
- Set_Is_Public (Id, Is_Public (Prev));
- Set_Is_Internal (Id);
- New_Id := Prev;
+ Set_Error_Posted (T);
- -- If the incomplete view is tagged, a class_wide type has been
- -- created already. Use it for the private type as well, in order
- -- to prevent multiple incompatible class-wide types that may be
- -- created for self-referential anonymous access components.
+ -- Check that within the immediate scope of an untagged partial
+ -- view it's illegal to derive from the partial view if the
+ -- full view is tagged. (7.3(7))
- if Is_Tagged_Type (Prev)
- and then Present (Class_Wide_Type (Prev))
- then
- Set_Ekind (Id, Ekind (Prev)); -- will be reset later
- Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
+ -- We verify that the Parent_Type is a partial view by checking
+ -- that it is not a Full_Type_Declaration (i.e. a private type or
+ -- private extension declaration), to distinguish a partial view
+ -- from a derivation from a private type which also appears as
+ -- E_Private_Type. If the parent base type is not declared in an
+ -- enclosing scope there is no need to check.
- -- If the incomplete type is completed by a private declaration
- -- the class-wide type remains associated with the incomplete
- -- type, to prevent order-of-elaboration issues in gigi, else
- -- we associate the class-wide type with the known full view.
+ elsif Present (Full_View (Parent_Type))
+ and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration
+ and then not Is_Tagged_Type (Parent_Type)
+ and then Is_Tagged_Type (Full_View (Parent_Type))
+ and then In_Open_Scopes (Scope (Base_Type (Parent_Type)))
+ then
+ Error_Msg_N
+ ("premature derivation from type with tagged full view",
+ Indic);
+ end if;
+ end if;
- if Nkind (N) /= N_Private_Type_Declaration then
- Set_Etype (Class_Wide_Type (Id), Id);
- end if;
- end if;
+ -- Check that form of derivation is appropriate
- -- Case of full declaration of private type
+ Taggd := Is_Tagged_Type (Parent_Type);
- else
- -- If the private type was a completion of an incomplete type then
- -- update Prev to reference the private type
+ -- Perhaps the parent type should be changed to the class-wide type's
+ -- specific type in this case to prevent cascading errors ???
- if Ada_Version >= Ada_2012
- and then Ekind (Prev) = E_Incomplete_Type
- and then Present (Full_View (Prev))
- and then Is_Private_Type (Full_View (Prev))
- then
- Prev := Full_View (Prev);
- Prev_Par := Parent (Prev);
- end if;
+ if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then
+ Error_Msg_N ("parent type must not be a class-wide type", Indic);
+ return;
+ end if;
- if Nkind (N) = N_Full_Type_Declaration
- and then Nkind_In
- (Type_Definition (N), N_Record_Definition,
- N_Derived_Type_Definition)
- and then Interface_Present (Type_Definition (N))
- then
- Error_Msg_N
- ("completion of private type cannot be an interface", N);
- end if;
+ if Present (Extension) and then not Taggd then
+ Error_Msg_N
+ ("type derived from untagged type cannot have extension", Indic);
- if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
- if Etype (Prev) /= Prev then
+ elsif No (Extension) and then Taggd then
- -- Prev is a private subtype or a derived type, and needs
- -- no completion.
+ -- If this declaration is within a private part (or body) of a
+ -- generic instantiation then the derivation is allowed (the parent
+ -- type can only appear tagged in this case if it's a generic actual
+ -- type, since it would otherwise have been rejected in the analysis
+ -- of the generic template).
- Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
- New_Id := Id;
+ if not Is_Generic_Actual_Type (Parent_Type)
+ or else In_Visible_Part (Scope (Parent_Type))
+ then
+ if Is_Class_Wide_Type (Parent_Type) then
+ Error_Msg_N
+ ("parent type must not be a class-wide type", Indic);
- elsif Ekind (Prev) = E_Private_Type
- and then Nkind_In (N, N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
- then
- Error_Msg_N
- ("completion of nonlimited type cannot be limited", N);
+ -- Use specific type to prevent cascaded errors.
- elsif Ekind (Prev) = E_Record_Type_With_Private
- and then Nkind_In (N, N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
- then
- if not Is_Limited_Record (Prev) then
- Error_Msg_N
- ("completion of nonlimited type cannot be limited", N);
+ Parent_Type := Etype (Parent_Type);
- elsif No (Interface_List (N)) then
- Error_Msg_N
- ("completion of tagged private type must be tagged",
- N);
- end if;
- end if;
+ else
+ Error_Msg_N
+ ("type derived from tagged type must have extension", Indic);
+ end if;
+ end if;
+ end if;
- -- Ada 2005 (AI-251): Private extension declaration of a task
- -- type or a protected type. This case arises when covering
- -- interface types.
+ -- AI-443: Synchronized formal derived types require a private
+ -- extension. There is no point in checking the ancestor type or
+ -- the progenitors since the construct is wrong to begin with.
- elsif Nkind_In (N, N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
- then
- null;
+ if Ada_Version >= Ada_2005
+ and then Is_Generic_Type (T)
+ and then Present (Original_Node (N))
+ then
+ declare
+ Decl : constant Node_Id := Original_Node (N);
- elsif Nkind (N) /= N_Full_Type_Declaration
- or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
- then
- Error_Msg_N
- ("full view of private extension must be an extension", N);
+ begin
+ if Nkind (Decl) = N_Formal_Type_Declaration
+ and then Nkind (Formal_Type_Definition (Decl)) =
+ N_Formal_Derived_Type_Definition
+ and then Synchronized_Present (Formal_Type_Definition (Decl))
+ and then No (Extension)
- elsif not (Abstract_Present (Parent (Prev)))
- and then Abstract_Present (Type_Definition (N))
+ -- Avoid emitting a duplicate error message
+
+ and then not Error_Posted (Indic)
then
Error_Msg_N
- ("full view of non-abstract extension cannot be abstract", N);
+ ("synchronized derived type must have extension", N);
end if;
+ end;
+ end if;
- if not In_Private_Part (Current_Scope) then
- Error_Msg_N
- ("declaration of full view must appear in private part", N);
- end if;
+ if Null_Exclusion_Present (Def)
+ and then not Is_Access_Type (Parent_Type)
+ then
+ Error_Msg_N ("null exclusion can only apply to an access type", N);
+ end if;
- if Ada_Version >= Ada_2012 then
- Check_Duplicate_Aspects;
- end if;
+ -- Avoid deriving parent primitives of underlying record views
- Copy_And_Swap (Prev, Id);
- Set_Has_Private_Declaration (Prev);
- Set_Has_Private_Declaration (Id);
+ Build_Derived_Type (N, Parent_Type, T, Is_Completion,
+ Derive_Subps => not Is_Underlying_Record_View (T));
- -- Preserve aspect and iterator flags that may have been set on
- -- the partial view.
+ -- AI-419: The parent type of an explicitly limited derived type must
+ -- be a limited type or a limited interface.
- Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
- Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
+ if Limited_Present (Def) then
+ Set_Is_Limited_Record (T);
- -- If no error, propagate freeze_node from private to full view.
- -- It may have been generated for an early operational item.
+ if Is_Interface (T) then
+ Set_Is_Limited_Interface (T);
+ end if;
- if Present (Freeze_Node (Id))
- and then Serious_Errors_Detected = 0
- and then No (Full_View (Id))
+ if not Is_Limited_Type (Parent_Type)
+ and then
+ (not Is_Interface (Parent_Type)
+ or else not Is_Limited_Interface (Parent_Type))
+ then
+ -- AI05-0096: a derivation in the private part of an instance is
+ -- legal if the generic formal is untagged limited, and the actual
+ -- is non-limited.
+
+ if Is_Generic_Actual_Type (Parent_Type)
+ and then In_Private_Part (Current_Scope)
+ and then
+ not Is_Tagged_Type
+ (Generic_Parent_Type (Parent (Parent_Type)))
then
- Set_Freeze_Node (Prev, Freeze_Node (Id));
- Set_Freeze_Node (Id, Empty);
- Set_First_Rep_Item (Prev, First_Rep_Item (Id));
- end if;
+ null;
- Set_Full_View (Id, Prev);
- New_Id := Prev;
+ else
+ Error_Msg_NE
+ ("parent type& of limited type must be limited",
+ N, Parent_Type);
+ end if;
end if;
+ end if;
- -- Verify that full declaration conforms to partial one
+ -- In SPARK, there are no derived type definitions other than type
+ -- extensions of tagged record types.
- if Is_Incomplete_Or_Private_Type (Prev)
- and then Present (Discriminant_Specifications (Prev_Par))
- then
- if Present (Discriminant_Specifications (N)) then
- if Ekind (Prev) = E_Incomplete_Type then
- Check_Discriminant_Conformance (N, Prev, Prev);
- else
- Check_Discriminant_Conformance (N, Prev, Id);
- end if;
+ if No (Extension) then
+ Check_SPARK_05_Restriction
+ ("derived type is not allowed", Original_Node (N));
+ end if;
+ end Derived_Type_Declaration;
- else
- Error_Msg_N
- ("missing discriminants in full type declaration", N);
+ ------------------------
+ -- Diagnose_Interface --
+ ------------------------
- -- To avoid cascaded errors on subsequent use, share the
- -- discriminants of the partial view.
+ procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is
+ begin
+ if not Is_Interface (E)
+ and then E /= Any_Type
+ then
+ Error_Msg_NE ("(Ada 2005) & must be an interface", N, E);
+ end if;
+ end Diagnose_Interface;
- Set_Discriminant_Specifications (N,
- Discriminant_Specifications (Prev_Par));
- end if;
- end if;
+ ----------------------------------
+ -- Enumeration_Type_Declaration --
+ ----------------------------------
- -- A prior untagged partial view can have an associated class-wide
- -- type due to use of the class attribute, and in this case the full
- -- type must also be tagged. This Ada 95 usage is deprecated in favor
- -- of incomplete tagged declarations, but we check for it.
+ procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+ Ev : Uint;
+ L : Node_Id;
+ R_Node : Node_Id;
+ B_Node : Node_Id;
- if Is_Type (Prev)
- and then (Is_Tagged_Type (Prev)
- or else Present (Class_Wide_Type (Prev)))
- then
- -- Ada 2012 (AI05-0162): A private type may be the completion of
- -- an incomplete type.
+ begin
+ -- Create identifier node representing lower bound
- if Ada_Version >= Ada_2012
- and then Is_Incomplete_Type (Prev)
- and then Nkind_In (N, N_Private_Type_Declaration,
- N_Private_Extension_Declaration)
- then
- -- No need to check private extensions since they are tagged
+ B_Node := New_Node (N_Identifier, Sloc (Def));
+ L := First (Literals (Def));
+ Set_Chars (B_Node, Chars (L));
+ Set_Entity (B_Node, L);
+ Set_Etype (B_Node, T);
+ Set_Is_Static_Expression (B_Node, True);
- if Nkind (N) = N_Private_Type_Declaration
- and then not Tagged_Present (N)
- then
- Tag_Mismatch;
- end if;
+ R_Node := New_Node (N_Range, Sloc (Def));
+ Set_Low_Bound (R_Node, B_Node);
- -- The full declaration is either a tagged type (including
- -- a synchronized type that implements interfaces) or a
- -- type extension, otherwise this is an error.
+ Set_Ekind (T, E_Enumeration_Type);
+ Set_First_Literal (T, L);
+ Set_Etype (T, T);
+ Set_Is_Constrained (T);
- elsif Nkind_In (N, N_Task_Type_Declaration,
- N_Protected_Type_Declaration)
- then
- if No (Interface_List (N))
- and then not Error_Posted (N)
- then
- Tag_Mismatch;
- end if;
+ Ev := Uint_0;
- elsif Nkind (Type_Definition (N)) = N_Record_Definition then
+ -- Loop through literals of enumeration type setting pos and rep values
+ -- except that if the Ekind is already set, then it means the literal
+ -- was already constructed (case of a derived type declaration and we
+ -- should not disturb the Pos and Rep values.
- -- Indicate that the previous declaration (tagged incomplete
- -- or private declaration) requires the same on the full one.
+ while Present (L) loop
+ if Ekind (L) /= E_Enumeration_Literal then
+ Set_Ekind (L, E_Enumeration_Literal);
+ Set_Enumeration_Pos (L, Ev);
+ Set_Enumeration_Rep (L, Ev);
+ Set_Is_Known_Valid (L, True);
+ end if;
- if not Tagged_Present (Type_Definition (N)) then
- Tag_Mismatch;
- Set_Is_Tagged_Type (Id);
- end if;
+ Set_Etype (L, T);
+ New_Overloaded_Entity (L);
+ Generate_Definition (L);
+ Set_Convention (L, Convention_Intrinsic);
- elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
- if No (Record_Extension_Part (Type_Definition (N))) then
- Error_Msg_NE
- ("full declaration of } must be a record extension",
- Prev, Id);
+ -- Case of character literal
- -- Set some attributes to produce a usable full view
+ if Nkind (L) = N_Defining_Character_Literal then
+ Set_Is_Character_Type (T, True);
- Set_Is_Tagged_Type (Id);
- end if;
+ -- Check violation of No_Wide_Characters
- else
- Tag_Mismatch;
- end if;
- end if;
+ if Restriction_Check_Required (No_Wide_Characters) then
+ Get_Name_String (Chars (L));
- if Present (Prev)
- and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration
- and then Present (Premature_Use (Parent (Prev)))
- then
- Error_Msg_Sloc := Sloc (N);
- Error_Msg_N
- ("\full declaration #", Premature_Use (Parent (Prev)));
+ if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then
+ Check_Restriction (No_Wide_Characters, L);
+ end if;
+ end if;
end if;
- return New_Id;
- end if;
- end Find_Type_Name;
-
- -------------------------
- -- Find_Type_Of_Object --
- -------------------------
+ Ev := Ev + 1;
+ Next (L);
+ end loop;
- function Find_Type_Of_Object
- (Obj_Def : Node_Id;
- Related_Nod : Node_Id) return Entity_Id
- is
- Def_Kind : constant Node_Kind := Nkind (Obj_Def);
- P : Node_Id := Parent (Obj_Def);
- T : Entity_Id;
- Nam : Name_Id;
+ -- Now create a node representing upper bound
- begin
- -- If the parent is a component_definition node we climb to the
- -- component_declaration node
+ B_Node := New_Node (N_Identifier, Sloc (Def));
+ Set_Chars (B_Node, Chars (Last (Literals (Def))));
+ Set_Entity (B_Node, Last (Literals (Def)));
+ Set_Etype (B_Node, T);
+ Set_Is_Static_Expression (B_Node, True);
- if Nkind (P) = N_Component_Definition then
- P := Parent (P);
- end if;
+ Set_High_Bound (R_Node, B_Node);
- -- Case of an anonymous array subtype
+ -- Initialize various fields of the type. Some of this information
+ -- may be overwritten later through rep.clauses.
- if Nkind_In (Def_Kind, N_Constrained_Array_Definition,
- N_Unconstrained_Array_Definition)
- then
- T := Empty;
- Array_Type_Declaration (T, Obj_Def);
+ Set_Scalar_Range (T, R_Node);
+ Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
+ Set_Enum_Esize (T);
+ Set_Enum_Pos_To_Rep (T, Empty);
- -- Create an explicit subtype whenever possible
+ -- Set Discard_Names if configuration pragma set, or if there is
+ -- a parameterless pragma in the current declarative region
- elsif Nkind (P) /= N_Component_Declaration
- and then Def_Kind = N_Subtype_Indication
- then
- -- Base name of subtype on object name, which will be unique in
- -- the current scope.
+ if Global_Discard_Names or else Discard_Names (Scope (T)) then
+ Set_Discard_Names (T);
+ end if;
- -- If this is a duplicate declaration, return base type, to avoid
- -- generating duplicate anonymous types.
+ -- Process end label if there is one
- if Error_Posted (P) then
- Analyze (Subtype_Mark (Obj_Def));
- return Entity (Subtype_Mark (Obj_Def));
- end if;
+ if Present (Def) then
+ Process_End_Label (Def, 'e', T);
+ end if;
+ end Enumeration_Type_Declaration;
- Nam :=
- New_External_Name
- (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T');
+ ---------------------------------
+ -- Expand_To_Stored_Constraint --
+ ---------------------------------
- T := Make_Defining_Identifier (Sloc (P), Nam);
+ function Expand_To_Stored_Constraint
+ (Typ : Entity_Id;
+ Constraint : Elist_Id) return Elist_Id
+ is
+ Explicitly_Discriminated_Type : Entity_Id;
+ Expansion : Elist_Id;
+ Discriminant : Entity_Id;
- Insert_Action (Obj_Def,
- Make_Subtype_Declaration (Sloc (P),
- Defining_Identifier => T,
- Subtype_Indication => Relocate_Node (Obj_Def)));
+ function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
+ -- Find the nearest type that actually specifies discriminants
- -- This subtype may need freezing, and this will not be done
- -- automatically if the object declaration is not in declarative
- -- part. Since this is an object declaration, the type cannot always
- -- be frozen here. Deferred constants do not freeze their type
- -- (which often enough will be private).
+ ---------------------------------
+ -- Type_With_Explicit_Discrims --
+ ---------------------------------
- if Nkind (P) = N_Object_Declaration
- and then Constant_Present (P)
- and then No (Expression (P))
- then
- null;
+ function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is
+ Typ : constant E := Base_Type (Id);
- -- Here we freeze the base type of object type to catch premature use
- -- of discriminated private type without a full view.
+ begin
+ if Ekind (Typ) in Incomplete_Or_Private_Kind then
+ if Present (Full_View (Typ)) then
+ return Type_With_Explicit_Discrims (Full_View (Typ));
+ end if;
else
- Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P));
+ if Has_Discriminants (Typ) then
+ return Typ;
+ end if;
end if;
- -- Ada 2005 AI-406: the object definition in an object declaration
- -- can be an access definition.
-
- elsif Def_Kind = N_Access_Definition then
- T := Access_Definition (Related_Nod, Obj_Def);
+ if Etype (Typ) = Typ then
+ return Empty;
+ elsif Has_Discriminants (Typ) then
+ return Typ;
+ else
+ return Type_With_Explicit_Discrims (Etype (Typ));
+ end if;
- Set_Is_Local_Anonymous_Access
- (T,
- V => (Ada_Version < Ada_2012)
- or else (Nkind (P) /= N_Object_Declaration)
- or else Is_Library_Level_Entity (Defining_Identifier (P)));
+ end Type_With_Explicit_Discrims;
- -- Otherwise, the object definition is just a subtype_mark
+ -- Start of processing for Expand_To_Stored_Constraint
- else
- T := Process_Subtype (Obj_Def, Related_Nod);
+ begin
+ if No (Constraint)
+ or else Is_Empty_Elmt_List (Constraint)
+ then
+ return No_Elist;
+ end if;
- -- If expansion is disabled an object definition that is an aggregate
- -- will not get expanded and may lead to scoping problems in the back
- -- end, if the object is referenced in an inner scope. In that case
- -- create an itype reference for the object definition now. This
- -- may be redundant in some cases, but harmless.
+ Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ);
- if Is_Itype (T)
- and then Nkind (Related_Nod) = N_Object_Declaration
- and then ASIS_Mode
- then
- Build_Itype_Reference (T, Related_Nod);
- end if;
+ if No (Explicitly_Discriminated_Type) then
+ return No_Elist;
end if;
- return T;
- end Find_Type_Of_Object;
-
- --------------------------------
- -- Find_Type_Of_Subtype_Indic --
- --------------------------------
+ Expansion := New_Elmt_List;
- function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is
- Typ : Entity_Id;
+ Discriminant :=
+ First_Stored_Discriminant (Explicitly_Discriminated_Type);
+ while Present (Discriminant) loop
+ Append_Elmt
+ (Get_Discriminant_Value
+ (Discriminant, Explicitly_Discriminated_Type, Constraint),
+ To => Expansion);
+ Next_Stored_Discriminant (Discriminant);
+ end loop;
- begin
- -- Case of subtype mark with a constraint
+ return Expansion;
+ end Expand_To_Stored_Constraint;
- if Nkind (S) = N_Subtype_Indication then
- Find_Type (Subtype_Mark (S));
- Typ := Entity (Subtype_Mark (S));
+ ---------------------------
+ -- Find_Hidden_Interface --
+ ---------------------------
- if not
- Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S)))
- then
- Error_Msg_N
- ("incorrect constraint for this kind of type", Constraint (S));
- Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
- end if;
+ function Find_Hidden_Interface
+ (Src : Elist_Id;
+ Dest : Elist_Id) return Entity_Id
+ is
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
- -- Otherwise we have a subtype mark without a constraint
+ begin
+ if Present (Src) and then Present (Dest) then
+ Iface_Elmt := First_Elmt (Src);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
- elsif Error_Posted (S) then
- Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
- return Any_Type;
+ if Is_Interface (Iface)
+ and then not Contain_Interface (Iface, Dest)
+ then
+ return Iface;
+ end if;
- else
- Find_Type (S);
- Typ := Entity (S);
+ Next_Elmt (Iface_Elmt);
+ end loop;
end if;
- -- Check No_Wide_Characters restriction
-
- Check_Wide_Character_Restriction (Typ, S);
-
- return Typ;
- end Find_Type_Of_Subtype_Indic;
-
- -------------------------------------
- -- Floating_Point_Type_Declaration --
- -------------------------------------
+ return Empty;
+ end Find_Hidden_Interface;
- procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
- Digs : constant Node_Id := Digits_Expression (Def);
- Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float);
- Digs_Val : Uint;
- Base_Typ : Entity_Id;
- Implicit_Base : Entity_Id;
- Bound : Node_Id;
+ --------------------
+ -- Find_Type_Name --
+ --------------------
- function Can_Derive_From (E : Entity_Id) return Boolean;
- -- Find if given digits value, and possibly a specified range, allows
- -- derivation from specified type
+ function Find_Type_Name (N : Node_Id) return Entity_Id is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Prev : Entity_Id;
+ New_Id : Entity_Id;
+ Prev_Par : Node_Id;
- function Find_Base_Type return Entity_Id;
- -- Find a predefined base type that Def can derive from, or generate
- -- an error and substitute Long_Long_Float if none exists.
+ procedure Check_Duplicate_Aspects;
+ -- Check that aspects specified in a completion have not been specified
+ -- already in the partial view. Type_Invariant and others can be
+ -- specified on either view but never on both.
- ---------------------
- -- Can_Derive_From --
- ---------------------
+ procedure Tag_Mismatch;
+ -- Diagnose a tagged partial view whose full view is untagged.
+ -- We post the message on the full view, with a reference to
+ -- the previous partial view. The partial view can be private
+ -- or incomplete, and these are handled in a different manner,
+ -- so we determine the position of the error message from the
+ -- respective slocs of both.
- function Can_Derive_From (E : Entity_Id) return Boolean is
- Spec : constant Entity_Id := Real_Range_Specification (Def);
+ -----------------------------
+ -- Check_Duplicate_Aspects --
+ -----------------------------
+ procedure Check_Duplicate_Aspects is
+ Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par);
+ Full_Aspects : constant List_Id := Aspect_Specifications (N);
+ F_Spec, P_Spec : Node_Id;
begin
- -- Check specified "digits" constraint
+ if Present (Prev_Aspects) and then Present (Full_Aspects) then
+ F_Spec := First (Full_Aspects);
+ while Present (F_Spec) loop
+ P_Spec := First (Prev_Aspects);
+ while Present (P_Spec) loop
+ if
+ Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec))
+ then
+ Error_Msg_N
+ ("aspect already specified in private declaration",
+ F_Spec);
+ Remove (F_Spec);
+ return;
+ end if;
+
+ Next (P_Spec);
+ end loop;
- if Digs_Val > Digits_Value (E) then
- return False;
+ Next (F_Spec);
+ end loop;
end if;
+ end Check_Duplicate_Aspects;
- -- Check for matching range, if specified
+ ------------------
+ -- Tag_Mismatch --
+ ------------------
- if Present (Spec) then
- if Expr_Value_R (Type_Low_Bound (E)) >
- Expr_Value_R (Low_Bound (Spec))
+ procedure Tag_Mismatch is
+ begin
+ if Sloc (Prev) < Sloc (Id) then
+ if Ada_Version >= Ada_2012
+ and then Nkind (N) = N_Private_Type_Declaration
then
- return False;
+ Error_Msg_NE
+ ("declaration of private } must be a tagged type ", Id, Prev);
+ else
+ Error_Msg_NE
+ ("full declaration of } must be a tagged type ", Id, Prev);
end if;
- if Expr_Value_R (Type_High_Bound (E)) <
- Expr_Value_R (High_Bound (Spec))
+ else
+ if Ada_Version >= Ada_2012
+ and then Nkind (N) = N_Private_Type_Declaration
then
- return False;
+ Error_Msg_NE
+ ("declaration of private } must be a tagged type ", Prev, Id);
+ else
+ Error_Msg_NE
+ ("full declaration of } must be a tagged type ", Prev, Id);
end if;
end if;
+ end Tag_Mismatch;
- return True;
- end Can_Derive_From;
-
- --------------------
- -- Find_Base_Type --
- --------------------
-
- function Find_Base_Type return Entity_Id is
- Choice : Elmt_Id := First_Elmt (Predefined_Float_Types);
-
- begin
- -- Iterate over the predefined types in order, returning the first
- -- one that Def can derive from.
-
- while Present (Choice) loop
- if Can_Derive_From (Node (Choice)) then
- return Node (Choice);
- end if;
-
- Next_Elmt (Choice);
- end loop;
+ -- Start of processing for Find_Type_Name
- -- If we can't derive from any existing type, use Long_Long_Float
- -- and give appropriate message explaining the problem.
+ begin
+ -- Find incomplete declaration, if one was given
- if Digs_Val > Max_Digs_Val then
- -- It might be the case that there is a type with the requested
- -- range, just not the combination of digits and range.
+ Prev := Current_Entity_In_Scope (Id);
- Error_Msg_N
- ("no predefined type has requested range and precision",
- Real_Range_Specification (Def));
+ -- New type declaration
- else
- Error_Msg_N
- ("range too large for any predefined type",
- Real_Range_Specification (Def));
- end if;
+ if No (Prev) then
+ Enter_Name (Id);
+ return Id;
- return Standard_Long_Long_Float;
- end Find_Base_Type;
+ -- Previous declaration exists
- -- Start of processing for Floating_Point_Type_Declaration
+ else
+ Prev_Par := Parent (Prev);
- begin
- Check_Restriction (No_Floating_Point, Def);
+ -- Error if not incomplete/private case except if previous
+ -- declaration is implicit, etc. Enter_Name will emit error if
+ -- appropriate.
- -- Create an implicit base type
+ if not Is_Incomplete_Or_Private_Type (Prev) then
+ Enter_Name (Id);
+ New_Id := Id;
- Implicit_Base :=
- Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');
+ -- Check invalid completion of private or incomplete type
- -- Analyze and verify digits value
+ elsif not Nkind_In (N, N_Full_Type_Declaration,
+ N_Task_Type_Declaration,
+ N_Protected_Type_Declaration)
+ and then
+ (Ada_Version < Ada_2012
+ or else not Is_Incomplete_Type (Prev)
+ or else not Nkind_In (N, N_Private_Type_Declaration,
+ N_Private_Extension_Declaration))
+ then
+ -- Completion must be a full type declarations (RM 7.3(4))
- Analyze_And_Resolve (Digs, Any_Integer);
- Check_Digits_Expression (Digs);
- Digs_Val := Expr_Value (Digs);
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_NE ("invalid completion of }", Id, Prev);
- -- Process possible range spec and find correct type to derive from
+ -- Set scope of Id to avoid cascaded errors. Entity is never
+ -- examined again, except when saving globals in generics.
- Process_Real_Range_Specification (Def);
+ Set_Scope (Id, Current_Scope);
+ New_Id := Id;
- -- Check that requested number of digits is not too high.
+ -- If this is a repeated incomplete declaration, no further
+ -- checks are possible.
- if Digs_Val > Max_Digs_Val then
- -- The check for Max_Base_Digits may be somewhat expensive, as it
- -- requires reading System, so only do it when necessary.
+ if Nkind (N) = N_Incomplete_Type_Declaration then
+ return Prev;
+ end if;
- declare
- Max_Base_Digits : constant Uint :=
- Expr_Value
- (Expression
- (Parent (RTE (RE_Max_Base_Digits))));
+ -- Case of full declaration of incomplete type
- begin
- if Digs_Val > Max_Base_Digits then
- Error_Msg_Uint_1 := Max_Base_Digits;
- Error_Msg_N ("digits value out of range, maximum is ^", Digs);
+ elsif Ekind (Prev) = E_Incomplete_Type
+ and then (Ada_Version < Ada_2012
+ or else No (Full_View (Prev))
+ or else not Is_Private_Type (Full_View (Prev)))
+ then
+ -- Indicate that the incomplete declaration has a matching full
+ -- declaration. The defining occurrence of the incomplete
+ -- declaration remains the visible one, and the procedure
+ -- Get_Full_View dereferences it whenever the type is used.
- elsif No (Real_Range_Specification (Def)) then
- Error_Msg_Uint_1 := Max_Digs_Val;
- Error_Msg_N ("types with more than ^ digits need range spec "
- & "(RM 3.5.7(6))", Digs);
+ if Present (Full_View (Prev)) then
+ Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
end if;
- end;
- end if;
-
- -- Find a suitable type to derive from or complain and use a substitute
- Base_Typ := Find_Base_Type;
+ Set_Full_View (Prev, Id);
+ Append_Entity (Id, Current_Scope);
+ Set_Is_Public (Id, Is_Public (Prev));
+ Set_Is_Internal (Id);
+ New_Id := Prev;
- -- If there are bounds given in the declaration use them as the bounds
- -- of the type, otherwise use the bounds of the predefined base type
- -- that was chosen based on the Digits value.
+ -- If the incomplete view is tagged, a class_wide type has been
+ -- created already. Use it for the private type as well, in order
+ -- to prevent multiple incompatible class-wide types that may be
+ -- created for self-referential anonymous access components.
- if Present (Real_Range_Specification (Def)) then
- Set_Scalar_Range (T, Real_Range_Specification (Def));
- Set_Is_Constrained (T);
+ if Is_Tagged_Type (Prev)
+ and then Present (Class_Wide_Type (Prev))
+ then
+ Set_Ekind (Id, Ekind (Prev)); -- will be reset later
+ Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
- -- The bounds of this range must be converted to machine numbers
- -- in accordance with RM 4.9(38).
+ -- If the incomplete type is completed by a private declaration
+ -- the class-wide type remains associated with the incomplete
+ -- type, to prevent order-of-elaboration issues in gigi, else
+ -- we associate the class-wide type with the known full view.
- Bound := Type_Low_Bound (T);
+ if Nkind (N) /= N_Private_Type_Declaration then
+ Set_Etype (Class_Wide_Type (Id), Id);
+ end if;
+ end if;
- if Nkind (Bound) = N_Real_Literal then
- Set_Realval
- (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
- Set_Is_Machine_Number (Bound);
- end if;
+ -- Case of full declaration of private type
- Bound := Type_High_Bound (T);
+ else
+ -- If the private type was a completion of an incomplete type then
+ -- update Prev to reference the private type
- if Nkind (Bound) = N_Real_Literal then
- Set_Realval
- (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
- Set_Is_Machine_Number (Bound);
- end if;
+ if Ada_Version >= Ada_2012
+ and then Ekind (Prev) = E_Incomplete_Type
+ and then Present (Full_View (Prev))
+ and then Is_Private_Type (Full_View (Prev))
+ then
+ Prev := Full_View (Prev);
+ Prev_Par := Parent (Prev);
+ end if;
- else
- Set_Scalar_Range (T, Scalar_Range (Base_Typ));
- end if;
+ if Nkind (N) = N_Full_Type_Declaration
+ and then Nkind_In
+ (Type_Definition (N), N_Record_Definition,
+ N_Derived_Type_Definition)
+ and then Interface_Present (Type_Definition (N))
+ then
+ Error_Msg_N
+ ("completion of private type cannot be an interface", N);
+ end if;
- -- Complete definition of implicit base and declared first subtype
+ if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
+ if Etype (Prev) /= Prev then
- Set_Etype (Implicit_Base, Base_Typ);
+ -- Prev is a private subtype or a derived type, and needs
+ -- no completion.
- Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
- Set_Size_Info (Implicit_Base, (Base_Typ));
- Set_RM_Size (Implicit_Base, RM_Size (Base_Typ));
- Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
- Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ));
- Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ));
+ Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
+ New_Id := Id;
- Set_Ekind (T, E_Floating_Point_Subtype);
- Set_Etype (T, Implicit_Base);
+ elsif Ekind (Prev) = E_Private_Type
+ and then Nkind_In (N, N_Task_Type_Declaration,
+ N_Protected_Type_Declaration)
+ then
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", N);
- Set_Size_Info (T, (Implicit_Base));
- Set_RM_Size (T, RM_Size (Implicit_Base));
- Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
- Set_Digits_Value (T, Digs_Val);
- end Floating_Point_Type_Declaration;
+ elsif Ekind (Prev) = E_Record_Type_With_Private
+ and then Nkind_In (N, N_Task_Type_Declaration,
+ N_Protected_Type_Declaration)
+ then
+ if not Is_Limited_Record (Prev) then
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", N);
- ----------------------------
- -- Get_Discriminant_Value --
- ----------------------------
+ elsif No (Interface_List (N)) then
+ Error_Msg_N
+ ("completion of tagged private type must be tagged",
+ N);
+ end if;
+ end if;
- -- This is the situation:
+ -- Ada 2005 (AI-251): Private extension declaration of a task
+ -- type or a protected type. This case arises when covering
+ -- interface types.
- -- There is a non-derived type
+ elsif Nkind_In (N, N_Task_Type_Declaration,
+ N_Protected_Type_Declaration)
+ then
+ null;
- -- type T0 (Dx, Dy, Dz...)
+ elsif Nkind (N) /= N_Full_Type_Declaration
+ or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition
+ then
+ Error_Msg_N
+ ("full view of private extension must be an extension", N);
- -- There are zero or more levels of derivation, with each derivation
- -- either purely inheriting the discriminants, or defining its own.
+ elsif not (Abstract_Present (Parent (Prev)))
+ and then Abstract_Present (Type_Definition (N))
+ then
+ Error_Msg_N
+ ("full view of non-abstract extension cannot be abstract", N);
+ end if;
- -- type Ti is new Ti-1
- -- or
- -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
- -- or
- -- subtype Ti is ...
+ if not In_Private_Part (Current_Scope) then
+ Error_Msg_N
+ ("declaration of full view must appear in private part", N);
+ end if;
- -- The subtype issue is avoided by the use of Original_Record_Component,
- -- and the fact that derived subtypes also derive the constraints.
+ if Ada_Version >= Ada_2012 then
+ Check_Duplicate_Aspects;
+ end if;
- -- This chain leads back from
+ Copy_And_Swap (Prev, Id);
+ Set_Has_Private_Declaration (Prev);
+ Set_Has_Private_Declaration (Id);
- -- Typ_For_Constraint
+ -- Preserve aspect and iterator flags that may have been set on
+ -- the partial view.
- -- Typ_For_Constraint has discriminants, and the value for each
- -- discriminant is given by its corresponding Elmt of Constraints.
+ Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
+ Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
- -- Discriminant is some discriminant in this hierarchy
+ -- If no error, propagate freeze_node from private to full view.
+ -- It may have been generated for an early operational item.
- -- We need to return its value
+ if Present (Freeze_Node (Id))
+ and then Serious_Errors_Detected = 0
+ and then No (Full_View (Id))
+ then
+ Set_Freeze_Node (Prev, Freeze_Node (Id));
+ Set_Freeze_Node (Id, Empty);
+ Set_First_Rep_Item (Prev, First_Rep_Item (Id));
+ end if;
- -- We do this by recursively searching each level, and looking for
- -- Discriminant. Once we get to the bottom, we start backing up
- -- returning the value for it which may in turn be a discriminant
- -- further up, so on the backup we continue the substitution.
+ Set_Full_View (Id, Prev);
+ New_Id := Prev;
+ end if;
- function Get_Discriminant_Value
- (Discriminant : Entity_Id;
- Typ_For_Constraint : Entity_Id;
- Constraint : Elist_Id) return Node_Id
- is
- function Root_Corresponding_Discriminant
- (Discr : Entity_Id) return Entity_Id;
- -- Given a discriminant, traverse the chain of inherited discriminants
- -- and return the topmost discriminant.
+ -- Verify that full declaration conforms to partial one
- function Search_Derivation_Levels
- (Ti : Entity_Id;
- Discrim_Values : Elist_Id;
- Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id;
- -- This is the routine that performs the recursive search of levels
- -- as described above.
+ if Is_Incomplete_Or_Private_Type (Prev)
+ and then Present (Discriminant_Specifications (Prev_Par))
+ then
+ if Present (Discriminant_Specifications (N)) then
+ if Ekind (Prev) = E_Incomplete_Type then
+ Check_Discriminant_Conformance (N, Prev, Prev);
+ else
+ Check_Discriminant_Conformance (N, Prev, Id);
+ end if;
- -------------------------------------
- -- Root_Corresponding_Discriminant --
- -------------------------------------
+ else
+ Error_Msg_N
+ ("missing discriminants in full type declaration", N);
- function Root_Corresponding_Discriminant
- (Discr : Entity_Id) return Entity_Id
- is
- D : Entity_Id;
+ -- To avoid cascaded errors on subsequent use, share the
+ -- discriminants of the partial view.
- begin
- D := Discr;
- while Present (Corresponding_Discriminant (D)) loop
- D := Corresponding_Discriminant (D);
- end loop;
+ Set_Discriminant_Specifications (N,
+ Discriminant_Specifications (Prev_Par));
+ end if;
+ end if;
- return D;
- end Root_Corresponding_Discriminant;
+ -- A prior untagged partial view can have an associated class-wide
+ -- type due to use of the class attribute, and in this case the full
+ -- type must also be tagged. This Ada 95 usage is deprecated in favor
+ -- of incomplete tagged declarations, but we check for it.
- ------------------------------
- -- Search_Derivation_Levels --
- ------------------------------
+ if Is_Type (Prev)
+ and then (Is_Tagged_Type (Prev)
+ or else Present (Class_Wide_Type (Prev)))
+ then
+ -- Ada 2012 (AI05-0162): A private type may be the completion of
+ -- an incomplete type.
- function Search_Derivation_Levels
- (Ti : Entity_Id;
- Discrim_Values : Elist_Id;
- Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id
- is
- Assoc : Elmt_Id;
- Disc : Entity_Id;
- Result : Node_Or_Entity_Id;
- Result_Entity : Node_Id;
+ if Ada_Version >= Ada_2012
+ and then Is_Incomplete_Type (Prev)
+ and then Nkind_In (N, N_Private_Type_Declaration,
+ N_Private_Extension_Declaration)
+ then
+ -- No need to check private extensions since they are tagged
- begin
- -- If inappropriate type, return Error, this happens only in
- -- cascaded error situations, and we want to avoid a blow up.
+ if Nkind (N) = N_Private_Type_Declaration
+ and then not Tagged_Present (N)
+ then
+ Tag_Mismatch;
+ end if;
- if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then
- return Error;
- end if;
+ -- The full declaration is either a tagged type (including
+ -- a synchronized type that implements interfaces) or a
+ -- type extension, otherwise this is an error.
- -- Look deeper if possible. Use Stored_Constraints only for
- -- untagged types. For tagged types use the given constraint.
- -- This asymmetry needs explanation???
+ elsif Nkind_In (N, N_Task_Type_Declaration,
+ N_Protected_Type_Declaration)
+ then
+ if No (Interface_List (N))
+ and then not Error_Posted (N)
+ then
+ Tag_Mismatch;
+ end if;
- if not Stored_Discrim_Values
- and then Present (Stored_Constraint (Ti))
- and then not Is_Tagged_Type (Ti)
- then
- Result :=
- Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True);
- else
- declare
- Td : constant Entity_Id := Etype (Ti);
+ elsif Nkind (Type_Definition (N)) = N_Record_Definition then
- begin
- if Td = Ti then
- Result := Discriminant;
+ -- Indicate that the previous declaration (tagged incomplete
+ -- or private declaration) requires the same on the full one.
- else
- if Present (Stored_Constraint (Ti)) then
- Result :=
- Search_Derivation_Levels
- (Td, Stored_Constraint (Ti), True);
- else
- Result :=
- Search_Derivation_Levels
- (Td, Discrim_Values, Stored_Discrim_Values);
- end if;
+ if not Tagged_Present (Type_Definition (N)) then
+ Tag_Mismatch;
+ Set_Is_Tagged_Type (Id);
end if;
- end;
- end if;
- -- Extra underlying places to search, if not found above. For
- -- concurrent types, the relevant discriminant appears in the
- -- corresponding record. For a type derived from a private type
- -- without discriminant, the full view inherits the discriminants
- -- of the full view of the parent.
+ elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
+ if No (Record_Extension_Part (Type_Definition (N))) then
+ Error_Msg_NE
+ ("full declaration of } must be a record extension",
+ Prev, Id);
- if Result = Discriminant then
- if Is_Concurrent_Type (Ti)
- and then Present (Corresponding_Record_Type (Ti))
- then
- Result :=
- Search_Derivation_Levels (
- Corresponding_Record_Type (Ti),
- Discrim_Values,
- Stored_Discrim_Values);
+ -- Set some attributes to produce a usable full view
- elsif Is_Private_Type (Ti)
- and then not Has_Discriminants (Ti)
- and then Present (Full_View (Ti))
- and then Etype (Full_View (Ti)) /= Ti
- then
- Result :=
- Search_Derivation_Levels (
- Full_View (Ti),
- Discrim_Values,
- Stored_Discrim_Values);
+ Set_Is_Tagged_Type (Id);
+ end if;
+
+ else
+ Tag_Mismatch;
end if;
end if;
- -- If Result is not a (reference to a) discriminant, return it,
- -- otherwise set Result_Entity to the discriminant.
-
- if Nkind (Result) = N_Defining_Identifier then
- pragma Assert (Result = Discriminant);
- Result_Entity := Result;
+ if Present (Prev)
+ and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration
+ and then Present (Premature_Use (Parent (Prev)))
+ then
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_N
+ ("\full declaration #", Premature_Use (Parent (Prev)));
+ end if;
- else
- if not Denotes_Discriminant (Result) then
- return Result;
- end if;
+ return New_Id;
+ end if;
+ end Find_Type_Name;
- Result_Entity := Entity (Result);
- end if;
+ -------------------------
+ -- Find_Type_Of_Object --
+ -------------------------
- -- See if this level of derivation actually has discriminants
- -- because tagged derivations can add them, hence the lower
- -- levels need not have any.
+ function Find_Type_Of_Object
+ (Obj_Def : Node_Id;
+ Related_Nod : Node_Id) return Entity_Id
+ is
+ Def_Kind : constant Node_Kind := Nkind (Obj_Def);
+ P : Node_Id := Parent (Obj_Def);
+ T : Entity_Id;
+ Nam : Name_Id;
- if not Has_Discriminants (Ti) then
- return Result;
- end if;
+ begin
+ -- If the parent is a component_definition node we climb to the
+ -- component_declaration node
- -- Scan Ti's discriminants for Result_Entity,
- -- and return its corresponding value, if any.
+ if Nkind (P) = N_Component_Definition then
+ P := Parent (P);
+ end if;
- Result_Entity := Original_Record_Component (Result_Entity);
+ -- Case of an anonymous array subtype
- Assoc := First_Elmt (Discrim_Values);
+ if Nkind_In (Def_Kind, N_Constrained_Array_Definition,
+ N_Unconstrained_Array_Definition)
+ then
+ T := Empty;
+ Array_Type_Declaration (T, Obj_Def);
- if Stored_Discrim_Values then
- Disc := First_Stored_Discriminant (Ti);
- else
- Disc := First_Discriminant (Ti);
- end if;
+ -- Create an explicit subtype whenever possible
- while Present (Disc) loop
- pragma Assert (Present (Assoc));
+ elsif Nkind (P) /= N_Component_Declaration
+ and then Def_Kind = N_Subtype_Indication
+ then
+ -- Base name of subtype on object name, which will be unique in
+ -- the current scope.
- if Original_Record_Component (Disc) = Result_Entity then
- return Node (Assoc);
- end if;
+ -- If this is a duplicate declaration, return base type, to avoid
+ -- generating duplicate anonymous types.
- Next_Elmt (Assoc);
+ if Error_Posted (P) then
+ Analyze (Subtype_Mark (Obj_Def));
+ return Entity (Subtype_Mark (Obj_Def));
+ end if;
- if Stored_Discrim_Values then
- Next_Stored_Discriminant (Disc);
- else
- Next_Discriminant (Disc);
- end if;
- end loop;
+ Nam :=
+ New_External_Name
+ (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T');
- -- Could not find it
- --
- return Result;
- end Search_Derivation_Levels;
+ T := Make_Defining_Identifier (Sloc (P), Nam);
- -- Local Variables
+ Insert_Action (Obj_Def,
+ Make_Subtype_Declaration (Sloc (P),
+ Defining_Identifier => T,
+ Subtype_Indication => Relocate_Node (Obj_Def)));
- Result : Node_Or_Entity_Id;
+ -- This subtype may need freezing, and this will not be done
+ -- automatically if the object declaration is not in declarative
+ -- part. Since this is an object declaration, the type cannot always
+ -- be frozen here. Deferred constants do not freeze their type
+ -- (which often enough will be private).
- -- Start of processing for Get_Discriminant_Value
+ if Nkind (P) = N_Object_Declaration
+ and then Constant_Present (P)
+ and then No (Expression (P))
+ then
+ null;
- begin
- -- ??? This routine is a gigantic mess and will be deleted. For the
- -- time being just test for the trivial case before calling recurse.
+ -- Here we freeze the base type of object type to catch premature use
+ -- of discriminated private type without a full view.
- if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
- declare
- D : Entity_Id;
- E : Elmt_Id;
+ else
+ Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P));
+ end if;
- begin
- D := First_Discriminant (Typ_For_Constraint);
- E := First_Elmt (Constraint);
- while Present (D) loop
- if Chars (D) = Chars (Discriminant) then
- return Node (E);
- end if;
+ -- Ada 2005 AI-406: the object definition in an object declaration
+ -- can be an access definition.
- Next_Discriminant (D);
- Next_Elmt (E);
- end loop;
- end;
- end if;
+ elsif Def_Kind = N_Access_Definition then
+ T := Access_Definition (Related_Nod, Obj_Def);
- Result := Search_Derivation_Levels
- (Typ_For_Constraint, Constraint, False);
+ Set_Is_Local_Anonymous_Access
+ (T,
+ V => (Ada_Version < Ada_2012)
+ or else (Nkind (P) /= N_Object_Declaration)
+ or else Is_Library_Level_Entity (Defining_Identifier (P)));
- -- ??? hack to disappear when this routine is gone
+ -- Otherwise, the object definition is just a subtype_mark
- if Nkind (Result) = N_Defining_Identifier then
- declare
- D : Entity_Id;
- E : Elmt_Id;
+ else
+ T := Process_Subtype (Obj_Def, Related_Nod);
- begin
- D := First_Discriminant (Typ_For_Constraint);
- E := First_Elmt (Constraint);
- while Present (D) loop
- if Root_Corresponding_Discriminant (D) = Discriminant then
- return Node (E);
- end if;
+ -- If expansion is disabled an object definition that is an aggregate
+ -- will not get expanded and may lead to scoping problems in the back
+ -- end, if the object is referenced in an inner scope. In that case
+ -- create an itype reference for the object definition now. This
+ -- may be redundant in some cases, but harmless.
- Next_Discriminant (D);
- Next_Elmt (E);
- end loop;
- end;
+ if Is_Itype (T)
+ and then Nkind (Related_Nod) = N_Object_Declaration
+ and then ASIS_Mode
+ then
+ Build_Itype_Reference (T, Related_Nod);
+ end if;
end if;
- pragma Assert (Nkind (Result) /= N_Defining_Identifier);
- return Result;
- end Get_Discriminant_Value;
+ return T;
+ end Find_Type_Of_Object;
- --------------------------
- -- Has_Range_Constraint --
- --------------------------
+ --------------------------------
+ -- Find_Type_Of_Subtype_Indic --
+ --------------------------------
- function Has_Range_Constraint (N : Node_Id) return Boolean is
- C : constant Node_Id := Constraint (N);
+ function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is
+ Typ : Entity_Id;
begin
- if Nkind (C) = N_Range_Constraint then
- return True;
+ -- Case of subtype mark with a constraint
- elsif Nkind (C) = N_Digits_Constraint then
- return
- Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
- or else
- Present (Range_Constraint (C));
+ if Nkind (S) = N_Subtype_Indication then
+ Find_Type (Subtype_Mark (S));
+ Typ := Entity (Subtype_Mark (S));
- elsif Nkind (C) = N_Delta_Constraint then
- return Present (Range_Constraint (C));
+ if not
+ Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S)))
+ then
+ Error_Msg_N
+ ("incorrect constraint for this kind of type", Constraint (S));
+ Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
+ end if;
+
+ -- Otherwise we have a subtype mark without a constraint
+
+ elsif Error_Posted (S) then
+ Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
+ return Any_Type;
else
- return False;
+ Find_Type (S);
+ Typ := Entity (S);
end if;
- end Has_Range_Constraint;
- ------------------------
- -- Inherit_Components --
- ------------------------
+ -- Check No_Wide_Characters restriction
- function Inherit_Components
- (N : Node_Id;
- Parent_Base : Entity_Id;
- Derived_Base : Entity_Id;
- Is_Tagged : Boolean;
- Inherit_Discr : Boolean;
- Discs : Elist_Id) return Elist_Id
- is
- Assoc_List : constant Elist_Id := New_Elmt_List;
+ Check_Wide_Character_Restriction (Typ, S);
- procedure Inherit_Component
- (Old_C : Entity_Id;
- Plain_Discrim : Boolean := False;
- Stored_Discrim : Boolean := False);
- -- Inherits component Old_C from Parent_Base to the Derived_Base. If
- -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is
- -- True, Old_C is a stored discriminant. If they are both false then
- -- Old_C is a regular component.
+ return Typ;
+ end Find_Type_Of_Subtype_Indic;
- -----------------------
- -- Inherit_Component --
- -----------------------
+ -------------------------------------
+ -- Floating_Point_Type_Declaration --
+ -------------------------------------
- procedure Inherit_Component
- (Old_C : Entity_Id;
- Plain_Discrim : Boolean := False;
- Stored_Discrim : Boolean := False)
- is
- procedure Set_Anonymous_Type (Id : Entity_Id);
- -- Id denotes the entity of an access discriminant or anonymous
- -- access component. Set the type of Id to either the same type of
- -- Old_C or create a new one depending on whether the parent and
- -- the child types are in the same scope.
+ procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+ Digs : constant Node_Id := Digits_Expression (Def);
+ Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float);
+ Digs_Val : Uint;
+ Base_Typ : Entity_Id;
+ Implicit_Base : Entity_Id;
+ Bound : Node_Id;
- ------------------------
- -- Set_Anonymous_Type --
- ------------------------
+ function Can_Derive_From (E : Entity_Id) return Boolean;
+ -- Find if given digits value, and possibly a specified range, allows
+ -- derivation from specified type
- procedure Set_Anonymous_Type (Id : Entity_Id) is
- Old_Typ : constant Entity_Id := Etype (Old_C);
+ function Find_Base_Type return Entity_Id;
+ -- Find a predefined base type that Def can derive from, or generate
+ -- an error and substitute Long_Long_Float if none exists.
- begin
- if Scope (Parent_Base) = Scope (Derived_Base) then
- Set_Etype (Id, Old_Typ);
+ ---------------------
+ -- Can_Derive_From --
+ ---------------------
- -- The parent and the derived type are in two different scopes.
- -- Reuse the type of the original discriminant / component by
- -- copying it in order to preserve all attributes.
+ function Can_Derive_From (E : Entity_Id) return Boolean is
+ Spec : constant Entity_Id := Real_Range_Specification (Def);
- else
- declare
- Typ : constant Entity_Id := New_Copy (Old_Typ);
+ begin
+ -- Check specified "digits" constraint
- begin
- Set_Etype (Id, Typ);
+ if Digs_Val > Digits_Value (E) then
+ return False;
+ end if;
- -- Since we do not generate component declarations for
- -- inherited components, associate the itype with the
- -- derived type.
+ -- Check for matching range, if specified
- Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base));
- Set_Scope (Typ, Derived_Base);
- end;
+ if Present (Spec) then
+ if Expr_Value_R (Type_Low_Bound (E)) >
+ Expr_Value_R (Low_Bound (Spec))
+ then
+ return False;
end if;
- end Set_Anonymous_Type;
- -- Local variables and constants
+ if Expr_Value_R (Type_High_Bound (E)) <
+ Expr_Value_R (High_Bound (Spec))
+ then
+ return False;
+ end if;
+ end if;
- New_C : constant Entity_Id := New_Copy (Old_C);
+ return True;
+ end Can_Derive_From;
- Corr_Discrim : Entity_Id;
- Discrim : Entity_Id;
+ --------------------
+ -- Find_Base_Type --
+ --------------------
- -- Start of processing for Inherit_Component
+ function Find_Base_Type return Entity_Id is
+ Choice : Elmt_Id := First_Elmt (Predefined_Float_Types);
begin
- pragma Assert (not Is_Tagged or else not Stored_Discrim);
-
- Set_Parent (New_C, Parent (Old_C));
+ -- Iterate over the predefined types in order, returning the first
+ -- one that Def can derive from.
- -- Regular discriminants and components must be inserted in the scope
- -- of the Derived_Base. Do it here.
+ while Present (Choice) loop
+ if Can_Derive_From (Node (Choice)) then
+ return Node (Choice);
+ end if;
- if not Stored_Discrim then
- Enter_Name (New_C);
- end if;
+ Next_Elmt (Choice);
+ end loop;
- -- For tagged types the Original_Record_Component must point to
- -- whatever this field was pointing to in the parent type. This has
- -- already been achieved by the call to New_Copy above.
+ -- If we can't derive from any existing type, use Long_Long_Float
+ -- and give appropriate message explaining the problem.
- if not Is_Tagged then
- Set_Original_Record_Component (New_C, New_C);
- end if;
+ if Digs_Val > Max_Digs_Val then
+ -- It might be the case that there is a type with the requested
+ -- range, just not the combination of digits and range.
- -- Set the proper type of an access discriminant
+ Error_Msg_N
+ ("no predefined type has requested range and precision",
+ Real_Range_Specification (Def));
- if Ekind (New_C) = E_Discriminant
- and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type
- then
- Set_Anonymous_Type (New_C);
+ else
+ Error_Msg_N
+ ("range too large for any predefined type",
+ Real_Range_Specification (Def));
end if;
- -- If we have inherited a component then see if its Etype contains
- -- references to Parent_Base discriminants. In this case, replace
- -- these references with the constraints given in Discs. We do not
- -- do this for the partial view of private types because this is
- -- not needed (only the components of the full view will be used
- -- for code generation) and cause problem. We also avoid this
- -- transformation in some error situations.
+ return Standard_Long_Long_Float;
+ end Find_Base_Type;
- if Ekind (New_C) = E_Component then
+ -- Start of processing for Floating_Point_Type_Declaration
- -- Set the proper type of an anonymous access component
+ begin
+ Check_Restriction (No_Floating_Point, Def);
- if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then
- Set_Anonymous_Type (New_C);
+ -- Create an implicit base type
- elsif (Is_Private_Type (Derived_Base)
- and then not Is_Generic_Type (Derived_Base))
- or else (Is_Empty_Elmt_List (Discs)
- and then not Expander_Active)
- then
- Set_Etype (New_C, Etype (Old_C));
+ Implicit_Base :=
+ Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');
- else
- -- The current component introduces a circularity of the
- -- following kind:
+ -- Analyze and verify digits value
- -- limited with Pack_2;
- -- package Pack_1 is
- -- type T_1 is tagged record
- -- Comp : access Pack_2.T_2;
- -- ...
- -- end record;
- -- end Pack_1;
+ Analyze_And_Resolve (Digs, Any_Integer);
+ Check_Digits_Expression (Digs);
+ Digs_Val := Expr_Value (Digs);
- -- with Pack_1;
- -- package Pack_2 is
- -- type T_2 is new Pack_1.T_1 with ...;
- -- end Pack_2;
+ -- Process possible range spec and find correct type to derive from
- Set_Etype
- (New_C,
- Constrain_Component_Type
- (Old_C, Derived_Base, N, Parent_Base, Discs));
- end if;
- end if;
+ Process_Real_Range_Specification (Def);
- -- In derived tagged types it is illegal to reference a non
- -- discriminant component in the parent type. To catch this, mark
- -- these components with an Ekind of E_Void. This will be reset in
- -- Record_Type_Definition after processing the record extension of
- -- the derived type.
+ -- Check that requested number of digits is not too high.
- -- If the declaration is a private extension, there is no further
- -- record extension to process, and the components retain their
- -- current kind, because they are visible at this point.
+ if Digs_Val > Max_Digs_Val then
+ -- The check for Max_Base_Digits may be somewhat expensive, as it
+ -- requires reading System, so only do it when necessary.
- if Is_Tagged and then Ekind (New_C) = E_Component
- and then Nkind (N) /= N_Private_Extension_Declaration
- then
- Set_Ekind (New_C, E_Void);
- end if;
+ declare
+ Max_Base_Digits : constant Uint :=
+ Expr_Value
+ (Expression
+ (Parent (RTE (RE_Max_Base_Digits))));
- if Plain_Discrim then
- Set_Corresponding_Discriminant (New_C, Old_C);
- Build_Discriminal (New_C);
+ begin
+ if Digs_Val > Max_Base_Digits then
+ Error_Msg_Uint_1 := Max_Base_Digits;
+ Error_Msg_N ("digits value out of range, maximum is ^", Digs);
- -- If we are explicitly inheriting a stored discriminant it will be
- -- completely hidden.
+ elsif No (Real_Range_Specification (Def)) then
+ Error_Msg_Uint_1 := Max_Digs_Val;
+ Error_Msg_N ("types with more than ^ digits need range spec "
+ & "(RM 3.5.7(6))", Digs);
+ end if;
+ end;
+ end if;
- elsif Stored_Discrim then
- Set_Corresponding_Discriminant (New_C, Empty);
- Set_Discriminal (New_C, Empty);
- Set_Is_Completely_Hidden (New_C);
+ -- Find a suitable type to derive from or complain and use a substitute
- -- Set the Original_Record_Component of each discriminant in the
- -- derived base to point to the corresponding stored that we just
- -- created.
+ Base_Typ := Find_Base_Type;
- Discrim := First_Discriminant (Derived_Base);
- while Present (Discrim) loop
- Corr_Discrim := Corresponding_Discriminant (Discrim);
+ -- If there are bounds given in the declaration use them as the bounds
+ -- of the type, otherwise use the bounds of the predefined base type
+ -- that was chosen based on the Digits value.
- -- Corr_Discrim could be missing in an error situation
+ if Present (Real_Range_Specification (Def)) then
+ Set_Scalar_Range (T, Real_Range_Specification (Def));
+ Set_Is_Constrained (T);
- if Present (Corr_Discrim)
- and then Original_Record_Component (Corr_Discrim) = Old_C
- then
- Set_Original_Record_Component (Discrim, New_C);
- end if;
+ -- The bounds of this range must be converted to machine numbers
+ -- in accordance with RM 4.9(38).
- Next_Discriminant (Discrim);
- end loop;
+ Bound := Type_Low_Bound (T);
- Append_Entity (New_C, Derived_Base);
+ if Nkind (Bound) = N_Real_Literal then
+ Set_Realval
+ (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
+ Set_Is_Machine_Number (Bound);
end if;
- if not Is_Tagged then
- Append_Elmt (Old_C, Assoc_List);
- Append_Elmt (New_C, Assoc_List);
+ Bound := Type_High_Bound (T);
+
+ if Nkind (Bound) = N_Real_Literal then
+ Set_Realval
+ (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
+ Set_Is_Machine_Number (Bound);
end if;
- end Inherit_Component;
- -- Variables local to Inherit_Component
+ else
+ Set_Scalar_Range (T, Scalar_Range (Base_Typ));
+ end if;
- Loc : constant Source_Ptr := Sloc (N);
+ -- Complete definition of implicit base and declared first subtype
- Parent_Discrim : Entity_Id;
- Stored_Discrim : Entity_Id;
- D : Entity_Id;
- Component : Entity_Id;
+ Set_Etype (Implicit_Base, Base_Typ);
- -- Start of processing for Inherit_Components
+ Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
+ Set_Size_Info (Implicit_Base, (Base_Typ));
+ Set_RM_Size (Implicit_Base, RM_Size (Base_Typ));
+ Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
+ Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ));
+ Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ));
- begin
- if not Is_Tagged then
- Append_Elmt (Parent_Base, Assoc_List);
- Append_Elmt (Derived_Base, Assoc_List);
- end if;
+ Set_Ekind (T, E_Floating_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
- -- Inherit parent discriminants if needed
+ Set_Size_Info (T, (Implicit_Base));
+ Set_RM_Size (T, RM_Size (Implicit_Base));
+ Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+ Set_Digits_Value (T, Digs_Val);
+ end Floating_Point_Type_Declaration;
- if Inherit_Discr then
- Parent_Discrim := First_Discriminant (Parent_Base);
- while Present (Parent_Discrim) loop
- Inherit_Component (Parent_Discrim, Plain_Discrim => True);
- Next_Discriminant (Parent_Discrim);
- end loop;
- end if;
+ ----------------------------
+ -- Get_Discriminant_Value --
+ ----------------------------
- -- Create explicit stored discrims for untagged types when necessary
+ -- This is the situation:
- if not Has_Unknown_Discriminants (Derived_Base)
- and then Has_Discriminants (Parent_Base)
- and then not Is_Tagged
- and then
- (not Inherit_Discr
- or else First_Discriminant (Parent_Base) /=
- First_Stored_Discriminant (Parent_Base))
- then
- Stored_Discrim := First_Stored_Discriminant (Parent_Base);
- while Present (Stored_Discrim) loop
- Inherit_Component (Stored_Discrim, Stored_Discrim => True);
- Next_Stored_Discriminant (Stored_Discrim);
- end loop;
- end if;
+ -- There is a non-derived type
- -- See if we can apply the second transformation for derived types, as
- -- explained in point 6. in the comments above Build_Derived_Record_Type
- -- This is achieved by appending Derived_Base discriminants into Discs,
- -- which has the side effect of returning a non empty Discs list to the
- -- caller of Inherit_Components, which is what we want. This must be
- -- done for private derived types if there are explicit stored
- -- discriminants, to ensure that we can retrieve the values of the
- -- constraints provided in the ancestors.
+ -- type T0 (Dx, Dy, Dz...)
- if Inherit_Discr
- and then Is_Empty_Elmt_List (Discs)
- and then Present (First_Discriminant (Derived_Base))
- and then
- (not Is_Private_Type (Derived_Base)
- or else Is_Completely_Hidden
- (First_Stored_Discriminant (Derived_Base))
- or else Is_Generic_Type (Derived_Base))
- then
- D := First_Discriminant (Derived_Base);
- while Present (D) loop
- Append_Elmt (New_Occurrence_Of (D, Loc), Discs);
- Next_Discriminant (D);
- end loop;
- end if;
+ -- There are zero or more levels of derivation, with each derivation
+ -- either purely inheriting the discriminants, or defining its own.
- -- Finally, inherit non-discriminant components unless they are not
- -- visible because defined or inherited from the full view of the
- -- parent. Don't inherit the _parent field of the parent type.
+ -- type Ti is new Ti-1
+ -- or
+ -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y)
+ -- or
+ -- subtype Ti is ...
- Component := First_Entity (Parent_Base);
- while Present (Component) loop
+ -- The subtype issue is avoided by the use of Original_Record_Component,
+ -- and the fact that derived subtypes also derive the constraints.
- -- Ada 2005 (AI-251): Do not inherit components associated with
- -- secondary tags of the parent.
+ -- This chain leads back from
- if Ekind (Component) = E_Component
- and then Present (Related_Type (Component))
- then
- null;
+ -- Typ_For_Constraint
- elsif Ekind (Component) /= E_Component
- or else Chars (Component) = Name_uParent
- then
- null;
+ -- Typ_For_Constraint has discriminants, and the value for each
+ -- discriminant is given by its corresponding Elmt of Constraints.
- -- If the derived type is within the parent type's declarative
- -- region, then the components can still be inherited even though
- -- they aren't visible at this point. This can occur for cases
- -- such as within public child units where the components must
- -- become visible upon entering the child unit's private part.
+ -- Discriminant is some discriminant in this hierarchy
- elsif not Is_Visible_Component (Component)
- and then not In_Open_Scopes (Scope (Parent_Base))
- then
- null;
+ -- We need to return its value
- elsif Ekind_In (Derived_Base, E_Private_Type,
- E_Limited_Private_Type)
- then
- null;
+ -- We do this by recursively searching each level, and looking for
+ -- Discriminant. Once we get to the bottom, we start backing up
+ -- returning the value for it which may in turn be a discriminant
+ -- further up, so on the backup we continue the substitution.
- else
- Inherit_Component (Component);
- end if;
+ function Get_Discriminant_Value
+ (Discriminant : Entity_Id;
+ Typ_For_Constraint : Entity_Id;
+ Constraint : Elist_Id) return Node_Id
+ is
+ function Root_Corresponding_Discriminant
+ (Discr : Entity_Id) return Entity_Id;
+ -- Given a discriminant, traverse the chain of inherited discriminants
+ -- and return the topmost discriminant.
- Next_Entity (Component);
- end loop;
+ function Search_Derivation_Levels
+ (Ti : Entity_Id;
+ Discrim_Values : Elist_Id;
+ Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id;
+ -- This is the routine that performs the recursive search of levels
+ -- as described above.
- -- For tagged derived types, inherited discriminants cannot be used in
- -- component declarations of the record extension part. To achieve this
- -- we mark the inherited discriminants as not visible.
+ -------------------------------------
+ -- Root_Corresponding_Discriminant --
+ -------------------------------------
- if Is_Tagged and then Inherit_Discr then
- D := First_Discriminant (Derived_Base);
- while Present (D) loop
- Set_Is_Immediately_Visible (D, False);
- Next_Discriminant (D);
+ function Root_Corresponding_Discriminant
+ (Discr : Entity_Id) return Entity_Id
+ is
+ D : Entity_Id;
+
+ begin
+ D := Discr;
+ while Present (Corresponding_Discriminant (D)) loop
+ D := Corresponding_Discriminant (D);
end loop;
- end if;
- return Assoc_List;
- end Inherit_Components;
+ return D;
+ end Root_Corresponding_Discriminant;
- -----------------------------
- -- Inherit_Predicate_Flags --
- -----------------------------
+ ------------------------------
+ -- Search_Derivation_Levels --
+ ------------------------------
- procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
- begin
- Set_Has_Predicates (Subt, Has_Predicates (Par));
- Set_Has_Static_Predicate_Aspect
- (Subt, Has_Static_Predicate_Aspect (Par));
- Set_Has_Dynamic_Predicate_Aspect
- (Subt, Has_Dynamic_Predicate_Aspect (Par));
- end Inherit_Predicate_Flags;
+ function Search_Derivation_Levels
+ (Ti : Entity_Id;
+ Discrim_Values : Elist_Id;
+ Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id
+ is
+ Assoc : Elmt_Id;
+ Disc : Entity_Id;
+ Result : Node_Or_Entity_Id;
+ Result_Entity : Node_Id;
- -----------------------
- -- Is_Null_Extension --
- -----------------------
+ begin
+ -- If inappropriate type, return Error, this happens only in
+ -- cascaded error situations, and we want to avoid a blow up.
- function Is_Null_Extension (T : Entity_Id) return Boolean is
- Type_Decl : constant Node_Id := Parent (Base_Type (T));
- Comp_List : Node_Id;
- Comp : Node_Id;
+ if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then
+ return Error;
+ end if;
- begin
- if Nkind (Type_Decl) /= N_Full_Type_Declaration
- or else not Is_Tagged_Type (T)
- or else Nkind (Type_Definition (Type_Decl)) /=
- N_Derived_Type_Definition
- or else No (Record_Extension_Part (Type_Definition (Type_Decl)))
- then
- return False;
- end if;
+ -- Look deeper if possible. Use Stored_Constraints only for
+ -- untagged types. For tagged types use the given constraint.
+ -- This asymmetry needs explanation???
- Comp_List :=
- Component_List (Record_Extension_Part (Type_Definition (Type_Decl)));
+ if not Stored_Discrim_Values
+ and then Present (Stored_Constraint (Ti))
+ and then not Is_Tagged_Type (Ti)
+ then
+ Result :=
+ Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True);
+ else
+ declare
+ Td : constant Entity_Id := Etype (Ti);
- if Present (Discriminant_Specifications (Type_Decl)) then
- return False;
+ begin
+ if Td = Ti then
+ Result := Discriminant;
- elsif Present (Comp_List)
- and then Is_Non_Empty_List (Component_Items (Comp_List))
- then
- Comp := First (Component_Items (Comp_List));
+ else
+ if Present (Stored_Constraint (Ti)) then
+ Result :=
+ Search_Derivation_Levels
+ (Td, Stored_Constraint (Ti), True);
+ else
+ Result :=
+ Search_Derivation_Levels
+ (Td, Discrim_Values, Stored_Discrim_Values);
+ end if;
+ end if;
+ end;
+ end if;
- -- Only user-defined components are relevant. The component list
- -- may also contain a parent component and internal components
- -- corresponding to secondary tags, but these do not determine
- -- whether this is a null extension.
+ -- Extra underlying places to search, if not found above. For
+ -- concurrent types, the relevant discriminant appears in the
+ -- corresponding record. For a type derived from a private type
+ -- without discriminant, the full view inherits the discriminants
+ -- of the full view of the parent.
- while Present (Comp) loop
- if Comes_From_Source (Comp) then
- return False;
+ if Result = Discriminant then
+ if Is_Concurrent_Type (Ti)
+ and then Present (Corresponding_Record_Type (Ti))
+ then
+ Result :=
+ Search_Derivation_Levels (
+ Corresponding_Record_Type (Ti),
+ Discrim_Values,
+ Stored_Discrim_Values);
+
+ elsif Is_Private_Type (Ti)
+ and then not Has_Discriminants (Ti)
+ and then Present (Full_View (Ti))
+ and then Etype (Full_View (Ti)) /= Ti
+ then
+ Result :=
+ Search_Derivation_Levels (
+ Full_View (Ti),
+ Discrim_Values,
+ Stored_Discrim_Values);
end if;
+ end if;
- Next (Comp);
- end loop;
-
- return True;
- else
- return True;
- end if;
- end Is_Null_Extension;
+ -- If Result is not a (reference to a) discriminant, return it,
+ -- otherwise set Result_Entity to the discriminant.
- ------------------------------
- -- Is_Valid_Constraint_Kind --
- ------------------------------
+ if Nkind (Result) = N_Defining_Identifier then
+ pragma Assert (Result = Discriminant);
+ Result_Entity := Result;
- function Is_Valid_Constraint_Kind
- (T_Kind : Type_Kind;
- Constraint_Kind : Node_Kind) return Boolean
- is
- begin
- case T_Kind is
- when Enumeration_Kind |
- Integer_Kind =>
- return Constraint_Kind = N_Range_Constraint;
+ else
+ if not Denotes_Discriminant (Result) then
+ return Result;
+ end if;
- when Decimal_Fixed_Point_Kind =>
- return Nkind_In (Constraint_Kind, N_Digits_Constraint,
- N_Range_Constraint);
+ Result_Entity := Entity (Result);
+ end if;
- when Ordinary_Fixed_Point_Kind =>
- return Nkind_In (Constraint_Kind, N_Delta_Constraint,
- N_Range_Constraint);
+ -- See if this level of derivation actually has discriminants
+ -- because tagged derivations can add them, hence the lower
+ -- levels need not have any.
- when Float_Kind =>
- return Nkind_In (Constraint_Kind, N_Digits_Constraint,
- N_Range_Constraint);
+ if not Has_Discriminants (Ti) then
+ return Result;
+ end if;
- when Access_Kind |
- Array_Kind |
- E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- E_Incomplete_Type |
- Private_Kind |
- Concurrent_Kind =>
- return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
+ -- Scan Ti's discriminants for Result_Entity,
+ -- and return its corresponding value, if any.
- when others =>
- return True; -- Error will be detected later
- end case;
- end Is_Valid_Constraint_Kind;
+ Result_Entity := Original_Record_Component (Result_Entity);
- --------------------------
- -- Is_Visible_Component --
- --------------------------
+ Assoc := First_Elmt (Discrim_Values);
- function Is_Visible_Component
- (C : Entity_Id;
- N : Node_Id := Empty) return Boolean
- is
- Original_Comp : Entity_Id := Empty;
- Original_Scope : Entity_Id;
- Type_Scope : Entity_Id;
+ if Stored_Discrim_Values then
+ Disc := First_Stored_Discriminant (Ti);
+ else
+ Disc := First_Discriminant (Ti);
+ end if;
- function Is_Local_Type (Typ : Entity_Id) return Boolean;
- -- Check whether parent type of inherited component is declared locally,
- -- possibly within a nested package or instance. The current scope is
- -- the derived record itself.
+ while Present (Disc) loop
+ pragma Assert (Present (Assoc));
- -------------------
- -- Is_Local_Type --
- -------------------
+ if Original_Record_Component (Disc) = Result_Entity then
+ return Node (Assoc);
+ end if;
- function Is_Local_Type (Typ : Entity_Id) return Boolean is
- Scop : Entity_Id;
+ Next_Elmt (Assoc);
- begin
- Scop := Scope (Typ);
- while Present (Scop)
- and then Scop /= Standard_Standard
- loop
- if Scop = Scope (Current_Scope) then
- return True;
+ if Stored_Discrim_Values then
+ Next_Stored_Discriminant (Disc);
+ else
+ Next_Discriminant (Disc);
end if;
-
- Scop := Scope (Scop);
end loop;
- return False;
- end Is_Local_Type;
-
- -- Start of processing for Is_Visible_Component
-
- begin
- if Ekind_In (C, E_Component, E_Discriminant) then
- Original_Comp := Original_Record_Component (C);
- end if;
-
- if No (Original_Comp) then
-
- -- Premature usage, or previous error
+ -- Could not find it
+ --
+ return Result;
+ end Search_Derivation_Levels;
- return False;
+ -- Local Variables
- else
- Original_Scope := Scope (Original_Comp);
- Type_Scope := Scope (Base_Type (Scope (C)));
- end if;
+ Result : Node_Or_Entity_Id;
- -- This test only concerns tagged types
+ -- Start of processing for Get_Discriminant_Value
- if not Is_Tagged_Type (Original_Scope) then
- return True;
+ begin
+ -- ??? This routine is a gigantic mess and will be deleted. For the
+ -- time being just test for the trivial case before calling recurse.
- -- If it is _Parent or _Tag, there is no visibility issue
+ if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
+ declare
+ D : Entity_Id;
+ E : Elmt_Id;
- elsif not Comes_From_Source (Original_Comp) then
- return True;
+ begin
+ D := First_Discriminant (Typ_For_Constraint);
+ E := First_Elmt (Constraint);
+ while Present (D) loop
+ if Chars (D) = Chars (Discriminant) then
+ return Node (E);
+ end if;
- -- Discriminants are visible unless the (private) type has unknown
- -- discriminants. If the discriminant reference is inserted for a
- -- discriminant check on a full view it is also visible.
+ Next_Discriminant (D);
+ Next_Elmt (E);
+ end loop;
+ end;
+ end if;
- elsif Ekind (Original_Comp) = E_Discriminant
- and then
- (not Has_Unknown_Discriminants (Original_Scope)
- or else (Present (N)
- and then Nkind (N) = N_Selected_Component
- and then Nkind (Prefix (N)) = N_Type_Conversion
- and then not Comes_From_Source (Prefix (N))))
- then
- return True;
+ Result := Search_Derivation_Levels
+ (Typ_For_Constraint, Constraint, False);
- -- In the body of an instantiation, no need to check for the visibility
- -- of a component.
+ -- ??? hack to disappear when this routine is gone
- elsif In_Instance_Body then
- return True;
+ if Nkind (Result) = N_Defining_Identifier then
+ declare
+ D : Entity_Id;
+ E : Elmt_Id;
- -- If the component has been declared in an ancestor which is currently
- -- a private type, then it is not visible. The same applies if the
- -- component's containing type is not in an open scope and the original
- -- component's enclosing type is a visible full view of a private type
- -- (which can occur in cases where an attempt is being made to reference
- -- a component in a sibling package that is inherited from a visible
- -- component of a type in an ancestor package; the component in the
- -- sibling package should not be visible even though the component it
- -- inherited from is visible). This does not apply however in the case
- -- where the scope of the type is a private child unit, or when the
- -- parent comes from a local package in which the ancestor is currently
- -- visible. The latter suppression of visibility is needed for cases
- -- that are tested in B730006.
+ begin
+ D := First_Discriminant (Typ_For_Constraint);
+ E := First_Elmt (Constraint);
+ while Present (D) loop
+ if Root_Corresponding_Discriminant (D) = Discriminant then
+ return Node (E);
+ end if;
- elsif Is_Private_Type (Original_Scope)
- or else
- (not Is_Private_Descendant (Type_Scope)
- and then not In_Open_Scopes (Type_Scope)
- and then Has_Private_Declaration (Original_Scope))
- then
- -- If the type derives from an entity in a formal package, there
- -- are no additional visible components.
+ Next_Discriminant (D);
+ Next_Elmt (E);
+ end loop;
+ end;
+ end if;
- if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) =
- N_Formal_Package_Declaration
- then
- return False;
+ pragma Assert (Nkind (Result) /= N_Defining_Identifier);
+ return Result;
+ end Get_Discriminant_Value;
- -- if we are not in the private part of the current package, there
- -- are no additional visible components.
+ --------------------------
+ -- Has_Range_Constraint --
+ --------------------------
- elsif Ekind (Scope (Current_Scope)) = E_Package
- and then not In_Private_Part (Scope (Current_Scope))
- then
- return False;
- else
- return
- Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
- and then In_Open_Scopes (Scope (Original_Scope))
- and then Is_Local_Type (Type_Scope);
- end if;
+ function Has_Range_Constraint (N : Node_Id) return Boolean is
+ C : constant Node_Id := Constraint (N);
- -- There is another weird way in which a component may be invisible when
- -- the private and the full view are not derived from the same ancestor.
- -- Here is an example :
+ begin
+ if Nkind (C) = N_Range_Constraint then
+ return True;
- -- type A1 is tagged record F1 : integer; end record;
- -- type A2 is new A1 with record F2 : integer; end record;
- -- type T is new A1 with private;
- -- private
- -- type T is new A2 with null record;
+ elsif Nkind (C) = N_Digits_Constraint then
+ return
+ Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
+ or else
+ Present (Range_Constraint (C));
- -- In this case, the full view of T inherits F1 and F2 but the private
- -- view inherits only F1
+ elsif Nkind (C) = N_Delta_Constraint then
+ return Present (Range_Constraint (C));
else
- declare
- Ancestor : Entity_Id := Scope (C);
+ return False;
+ end if;
+ end Has_Range_Constraint;
- begin
- loop
- if Ancestor = Original_Scope then
- return True;
- elsif Ancestor = Etype (Ancestor) then
- return False;
- end if;
+ ------------------------
+ -- Inherit_Components --
+ ------------------------
- Ancestor := Etype (Ancestor);
- end loop;
- end;
- end if;
- end Is_Visible_Component;
+ function Inherit_Components
+ (N : Node_Id;
+ Parent_Base : Entity_Id;
+ Derived_Base : Entity_Id;
+ Is_Tagged : Boolean;
+ Inherit_Discr : Boolean;
+ Discs : Elist_Id) return Elist_Id
+ is
+ Assoc_List : constant Elist_Id := New_Elmt_List;
- --------------------------
- -- Make_Class_Wide_Type --
- --------------------------
+ procedure Inherit_Component
+ (Old_C : Entity_Id;
+ Plain_Discrim : Boolean := False;
+ Stored_Discrim : Boolean := False);
+ -- Inherits component Old_C from Parent_Base to the Derived_Base. If
+ -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is
+ -- True, Old_C is a stored discriminant. If they are both false then
+ -- Old_C is a regular component.
- procedure Make_Class_Wide_Type (T : Entity_Id) is
- CW_Type : Entity_Id;
- CW_Name : Name_Id;
- Next_E : Entity_Id;
+ -----------------------
+ -- Inherit_Component --
+ -----------------------
- begin
- if Present (Class_Wide_Type (T)) then
+ procedure Inherit_Component
+ (Old_C : Entity_Id;
+ Plain_Discrim : Boolean := False;
+ Stored_Discrim : Boolean := False)
+ is
+ procedure Set_Anonymous_Type (Id : Entity_Id);
+ -- Id denotes the entity of an access discriminant or anonymous
+ -- access component. Set the type of Id to either the same type of
+ -- Old_C or create a new one depending on whether the parent and
+ -- the child types are in the same scope.
- -- The class-wide type is a partially decorated entity created for a
- -- unanalyzed tagged type referenced through a limited with clause.
- -- When the tagged type is analyzed, its class-wide type needs to be
- -- redecorated. Note that we reuse the entity created by Decorate_
- -- Tagged_Type in order to preserve all links.
+ ------------------------
+ -- Set_Anonymous_Type --
+ ------------------------
- if Materialize_Entity (Class_Wide_Type (T)) then
- CW_Type := Class_Wide_Type (T);
- Set_Materialize_Entity (CW_Type, False);
+ procedure Set_Anonymous_Type (Id : Entity_Id) is
+ Old_Typ : constant Entity_Id := Etype (Old_C);
- -- The class wide type can have been defined by the partial view, in
- -- which case everything is already done.
+ begin
+ if Scope (Parent_Base) = Scope (Derived_Base) then
+ Set_Etype (Id, Old_Typ);
- else
- return;
- end if;
+ -- The parent and the derived type are in two different scopes.
+ -- Reuse the type of the original discriminant / component by
+ -- copying it in order to preserve all attributes.
- -- Default case, we need to create a new class-wide type
+ else
+ declare
+ Typ : constant Entity_Id := New_Copy (Old_Typ);
- else
- CW_Type :=
- New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');
- end if;
+ begin
+ Set_Etype (Id, Typ);
- -- Inherit root type characteristics
+ -- Since we do not generate component declarations for
+ -- inherited components, associate the itype with the
+ -- derived type.
- CW_Name := Chars (CW_Type);
- Next_E := Next_Entity (CW_Type);
- Copy_Node (T, CW_Type);
- Set_Comes_From_Source (CW_Type, False);
- Set_Chars (CW_Type, CW_Name);
- Set_Parent (CW_Type, Parent (T));
- Set_Next_Entity (CW_Type, Next_E);
+ Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base));
+ Set_Scope (Typ, Derived_Base);
+ end;
+ end if;
+ end Set_Anonymous_Type;
- -- Ensure we have a new freeze node for the class-wide type. The partial
- -- view may have freeze action of its own, requiring a proper freeze
- -- node, and the same freeze node cannot be shared between the two
- -- types.
+ -- Local variables and constants
- Set_Has_Delayed_Freeze (CW_Type);
- Set_Freeze_Node (CW_Type, Empty);
+ New_C : constant Entity_Id := New_Copy (Old_C);
- -- Customize the class-wide type: It has no prim. op., it cannot be
- -- abstract and its Etype points back to the specific root type.
+ Corr_Discrim : Entity_Id;
+ Discrim : Entity_Id;
- Set_Ekind (CW_Type, E_Class_Wide_Type);
- Set_Is_Tagged_Type (CW_Type, True);
- Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List);
- Set_Is_Abstract_Type (CW_Type, False);
- Set_Is_Constrained (CW_Type, False);
- Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
- Set_Default_SSO (CW_Type);
+ -- Start of processing for Inherit_Component
- if Ekind (T) = E_Class_Wide_Subtype then
- Set_Etype (CW_Type, Etype (Base_Type (T)));
- else
- Set_Etype (CW_Type, T);
- end if;
+ begin
+ pragma Assert (not Is_Tagged or else not Stored_Discrim);
- -- If this is the class_wide type of a constrained subtype, it does
- -- not have discriminants.
+ Set_Parent (New_C, Parent (Old_C));
- Set_Has_Discriminants (CW_Type,
- Has_Discriminants (T) and then not Is_Constrained (T));
+ -- Regular discriminants and components must be inserted in the scope
+ -- of the Derived_Base. Do it here.
- Set_Has_Unknown_Discriminants (CW_Type, True);
- Set_Class_Wide_Type (T, CW_Type);
- Set_Equivalent_Type (CW_Type, Empty);
+ if not Stored_Discrim then
+ Enter_Name (New_C);
+ end if;
- -- The class-wide type of a class-wide type is itself (RM 3.9(14))
+ -- For tagged types the Original_Record_Component must point to
+ -- whatever this field was pointing to in the parent type. This has
+ -- already been achieved by the call to New_Copy above.
- Set_Class_Wide_Type (CW_Type, CW_Type);
- end Make_Class_Wide_Type;
+ if not Is_Tagged then
+ Set_Original_Record_Component (New_C, New_C);
+ end if;
- ----------------
- -- Make_Index --
- ----------------
+ -- Set the proper type of an access discriminant
- procedure Make_Index
- (N : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id := Empty;
- Suffix_Index : Nat := 1;
- In_Iter_Schm : Boolean := False)
- is
- R : Node_Id;
- T : Entity_Id;
- Def_Id : Entity_Id := Empty;
- Found : Boolean := False;
+ if Ekind (New_C) = E_Discriminant
+ and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type
+ then
+ Set_Anonymous_Type (New_C);
+ end if;
- begin
- -- For a discrete range used in a constrained array definition and
- -- defined by a range, an implicit conversion to the predefined type
- -- INTEGER is assumed if each bound is either a numeric literal, a named
- -- number, or an attribute, and the type of both bounds (prior to the
- -- implicit conversion) is the type universal_integer. Otherwise, both
- -- bounds must be of the same discrete type, other than universal
- -- integer; this type must be determinable independently of the
- -- context, but using the fact that the type must be discrete and that
- -- both bounds must have the same type.
+ -- If we have inherited a component then see if its Etype contains
+ -- references to Parent_Base discriminants. In this case, replace
+ -- these references with the constraints given in Discs. We do not
+ -- do this for the partial view of private types because this is
+ -- not needed (only the components of the full view will be used
+ -- for code generation) and cause problem. We also avoid this
+ -- transformation in some error situations.
- -- Character literals also have a universal type in the absence of
- -- of additional context, and are resolved to Standard_Character.
+ if Ekind (New_C) = E_Component then
- if Nkind (N) = N_Range then
+ -- Set the proper type of an anonymous access component
- -- The index is given by a range constraint. The bounds are known
- -- to be of a consistent type.
+ if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then
+ Set_Anonymous_Type (New_C);
- if not Is_Overloaded (N) then
- T := Etype (N);
+ elsif (Is_Private_Type (Derived_Base)
+ and then not Is_Generic_Type (Derived_Base))
+ or else (Is_Empty_Elmt_List (Discs)
+ and then not Expander_Active)
+ then
+ Set_Etype (New_C, Etype (Old_C));
- -- For universal bounds, choose the specific predefined type
+ else
+ -- The current component introduces a circularity of the
+ -- following kind:
- if T = Universal_Integer then
- T := Standard_Integer;
+ -- limited with Pack_2;
+ -- package Pack_1 is
+ -- type T_1 is tagged record
+ -- Comp : access Pack_2.T_2;
+ -- ...
+ -- end record;
+ -- end Pack_1;
- elsif T = Any_Character then
- Ambiguous_Character (Low_Bound (N));
+ -- with Pack_1;
+ -- package Pack_2 is
+ -- type T_2 is new Pack_1.T_1 with ...;
+ -- end Pack_2;
+
+ Set_Etype
+ (New_C,
+ Constrain_Component_Type
+ (Old_C, Derived_Base, N, Parent_Base, Discs));
+ end if;
+ end if;
+
+ -- In derived tagged types it is illegal to reference a non
+ -- discriminant component in the parent type. To catch this, mark
+ -- these components with an Ekind of E_Void. This will be reset in
+ -- Record_Type_Definition after processing the record extension of
+ -- the derived type.
+
+ -- If the declaration is a private extension, there is no further
+ -- record extension to process, and the components retain their
+ -- current kind, because they are visible at this point.
- T := Standard_Character;
- end if;
+ if Is_Tagged and then Ekind (New_C) = E_Component
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ then
+ Set_Ekind (New_C, E_Void);
+ end if;
- -- The node may be overloaded because some user-defined operators
- -- are available, but if a universal interpretation exists it is
- -- also the selected one.
+ if Plain_Discrim then
+ Set_Corresponding_Discriminant (New_C, Old_C);
+ Build_Discriminal (New_C);
- elsif Universal_Interpretation (N) = Universal_Integer then
- T := Standard_Integer;
+ -- If we are explicitly inheriting a stored discriminant it will be
+ -- completely hidden.
- else
- T := Any_Type;
+ elsif Stored_Discrim then
+ Set_Corresponding_Discriminant (New_C, Empty);
+ Set_Discriminal (New_C, Empty);
+ Set_Is_Completely_Hidden (New_C);
- declare
- Ind : Interp_Index;
- It : Interp;
+ -- Set the Original_Record_Component of each discriminant in the
+ -- derived base to point to the corresponding stored that we just
+ -- created.
- begin
- Get_First_Interp (N, Ind, It);
- while Present (It.Typ) loop
- if Is_Discrete_Type (It.Typ) then
+ Discrim := First_Discriminant (Derived_Base);
+ while Present (Discrim) loop
+ Corr_Discrim := Corresponding_Discriminant (Discrim);
- if Found
- and then not Covers (It.Typ, T)
- and then not Covers (T, It.Typ)
- then
- Error_Msg_N ("ambiguous bounds in discrete range", N);
- exit;
- else
- T := It.Typ;
- Found := True;
- end if;
- end if;
+ -- Corr_Discrim could be missing in an error situation
- Get_Next_Interp (Ind, It);
- end loop;
+ if Present (Corr_Discrim)
+ and then Original_Record_Component (Corr_Discrim) = Old_C
+ then
+ Set_Original_Record_Component (Discrim, New_C);
+ end if;
- if T = Any_Type then
- Error_Msg_N ("discrete type required for range", N);
- Set_Etype (N, Any_Type);
- return;
+ Next_Discriminant (Discrim);
+ end loop;
- elsif T = Universal_Integer then
- T := Standard_Integer;
- end if;
- end;
+ Append_Entity (New_C, Derived_Base);
end if;
- if not Is_Discrete_Type (T) then
- Error_Msg_N ("discrete type required for range", N);
- Set_Etype (N, Any_Type);
- return;
+ if not Is_Tagged then
+ Append_Elmt (Old_C, Assoc_List);
+ Append_Elmt (New_C, Assoc_List);
end if;
+ end Inherit_Component;
- if Nkind (Low_Bound (N)) = N_Attribute_Reference
- and then Attribute_Name (Low_Bound (N)) = Name_First
- and then Is_Entity_Name (Prefix (Low_Bound (N)))
- and then Is_Type (Entity (Prefix (Low_Bound (N))))
- and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N))))
- then
- -- The type of the index will be the type of the prefix, as long
- -- as the upper bound is 'Last of the same type.
+ -- Variables local to Inherit_Component
- Def_Id := Entity (Prefix (Low_Bound (N)));
+ Loc : constant Source_Ptr := Sloc (N);
- if Nkind (High_Bound (N)) /= N_Attribute_Reference
- or else Attribute_Name (High_Bound (N)) /= Name_Last
- or else not Is_Entity_Name (Prefix (High_Bound (N)))
- or else Entity (Prefix (High_Bound (N))) /= Def_Id
- then
- Def_Id := Empty;
- end if;
- end if;
+ Parent_Discrim : Entity_Id;
+ Stored_Discrim : Entity_Id;
+ D : Entity_Id;
+ Component : Entity_Id;
- R := N;
- Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm);
+ -- Start of processing for Inherit_Components
- elsif Nkind (N) = N_Subtype_Indication then
+ begin
+ if not Is_Tagged then
+ Append_Elmt (Parent_Base, Assoc_List);
+ Append_Elmt (Derived_Base, Assoc_List);
+ end if;
- -- The index is given by a subtype with a range constraint
+ -- Inherit parent discriminants if needed
- T := Base_Type (Entity (Subtype_Mark (N)));
+ if Inherit_Discr then
+ Parent_Discrim := First_Discriminant (Parent_Base);
+ while Present (Parent_Discrim) loop
+ Inherit_Component (Parent_Discrim, Plain_Discrim => True);
+ Next_Discriminant (Parent_Discrim);
+ end loop;
+ end if;
- if not Is_Discrete_Type (T) then
- Error_Msg_N ("discrete type required for range", N);
- Set_Etype (N, Any_Type);
- return;
- end if;
+ -- Create explicit stored discrims for untagged types when necessary
- R := Range_Expression (Constraint (N));
+ if not Has_Unknown_Discriminants (Derived_Base)
+ and then Has_Discriminants (Parent_Base)
+ and then not Is_Tagged
+ and then
+ (not Inherit_Discr
+ or else First_Discriminant (Parent_Base) /=
+ First_Stored_Discriminant (Parent_Base))
+ then
+ Stored_Discrim := First_Stored_Discriminant (Parent_Base);
+ while Present (Stored_Discrim) loop
+ Inherit_Component (Stored_Discrim, Stored_Discrim => True);
+ Next_Stored_Discriminant (Stored_Discrim);
+ end loop;
+ end if;
- Resolve (R, T);
- Process_Range_Expr_In_Decl
- (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm);
+ -- See if we can apply the second transformation for derived types, as
+ -- explained in point 6. in the comments above Build_Derived_Record_Type
+ -- This is achieved by appending Derived_Base discriminants into Discs,
+ -- which has the side effect of returning a non empty Discs list to the
+ -- caller of Inherit_Components, which is what we want. This must be
+ -- done for private derived types if there are explicit stored
+ -- discriminants, to ensure that we can retrieve the values of the
+ -- constraints provided in the ancestors.
- elsif Nkind (N) = N_Attribute_Reference then
+ if Inherit_Discr
+ and then Is_Empty_Elmt_List (Discs)
+ and then Present (First_Discriminant (Derived_Base))
+ and then
+ (not Is_Private_Type (Derived_Base)
+ or else Is_Completely_Hidden
+ (First_Stored_Discriminant (Derived_Base))
+ or else Is_Generic_Type (Derived_Base))
+ then
+ D := First_Discriminant (Derived_Base);
+ while Present (D) loop
+ Append_Elmt (New_Occurrence_Of (D, Loc), Discs);
+ Next_Discriminant (D);
+ end loop;
+ end if;
- -- Catch beginner's error (use of attribute other than 'Range)
+ -- Finally, inherit non-discriminant components unless they are not
+ -- visible because defined or inherited from the full view of the
+ -- parent. Don't inherit the _parent field of the parent type.
- if Attribute_Name (N) /= Name_Range then
- Error_Msg_N ("expect attribute ''Range", N);
- Set_Etype (N, Any_Type);
- return;
- end if;
+ Component := First_Entity (Parent_Base);
+ while Present (Component) loop
- -- If the node denotes the range of a type mark, that is also the
- -- resulting type, and we do not need to create an Itype for it.
+ -- Ada 2005 (AI-251): Do not inherit components associated with
+ -- secondary tags of the parent.
- if Is_Entity_Name (Prefix (N))
- and then Comes_From_Source (N)
- and then Is_Type (Entity (Prefix (N)))
- and then Is_Discrete_Type (Entity (Prefix (N)))
+ if Ekind (Component) = E_Component
+ and then Present (Related_Type (Component))
then
- Def_Id := Entity (Prefix (N));
- end if;
+ null;
- Analyze_And_Resolve (N);
- T := Etype (N);
- R := N;
+ elsif Ekind (Component) /= E_Component
+ or else Chars (Component) = Name_uParent
+ then
+ null;
- -- If none of the above, must be a subtype. We convert this to a
- -- range attribute reference because in the case of declared first
- -- named subtypes, the types in the range reference can be different
- -- from the type of the entity. A range attribute normalizes the
- -- reference and obtains the correct types for the bounds.
+ -- If the derived type is within the parent type's declarative
+ -- region, then the components can still be inherited even though
+ -- they aren't visible at this point. This can occur for cases
+ -- such as within public child units where the components must
+ -- become visible upon entering the child unit's private part.
- -- This transformation is in the nature of an expansion, is only
- -- done if expansion is active. In particular, it is not done on
- -- formal generic types, because we need to retain the name of the
- -- original index for instantiation purposes.
+ elsif not Is_Visible_Component (Component)
+ and then not In_Open_Scopes (Scope (Parent_Base))
+ then
+ null;
- else
- if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then
- Error_Msg_N ("invalid subtype mark in discrete range ", N);
- Set_Etype (N, Any_Integer);
- return;
+ elsif Ekind_In (Derived_Base, E_Private_Type,
+ E_Limited_Private_Type)
+ then
+ null;
else
- -- The type mark may be that of an incomplete type. It is only
- -- now that we can get the full view, previous analysis does
- -- not look specifically for a type mark.
-
- Set_Entity (N, Get_Full_View (Entity (N)));
- Set_Etype (N, Entity (N));
- Def_Id := Entity (N);
-
- if not Is_Discrete_Type (Def_Id) then
- Error_Msg_N ("discrete type required for index", N);
- Set_Etype (N, Any_Type);
- return;
- end if;
+ Inherit_Component (Component);
end if;
- if Expander_Active then
- Rewrite (N,
- Make_Attribute_Reference (Sloc (N),
- Attribute_Name => Name_Range,
- Prefix => Relocate_Node (N)));
+ Next_Entity (Component);
+ end loop;
- -- The original was a subtype mark that does not freeze. This
- -- means that the rewritten version must not freeze either.
+ -- For tagged derived types, inherited discriminants cannot be used in
+ -- component declarations of the record extension part. To achieve this
+ -- we mark the inherited discriminants as not visible.
+
+ if Is_Tagged and then Inherit_Discr then
+ D := First_Discriminant (Derived_Base);
+ while Present (D) loop
+ Set_Is_Immediately_Visible (D, False);
+ Next_Discriminant (D);
+ end loop;
+ end if;
- Set_Must_Not_Freeze (N);
- Set_Must_Not_Freeze (Prefix (N));
- Analyze_And_Resolve (N);
- T := Etype (N);
- R := N;
+ return Assoc_List;
+ end Inherit_Components;
- -- If expander is inactive, type is legal, nothing else to construct
+ -----------------------------
+ -- Inherit_Predicate_Flags --
+ -----------------------------
- else
- return;
- end if;
- end if;
+ procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
+ begin
+ Set_Has_Predicates (Subt, Has_Predicates (Par));
+ Set_Has_Static_Predicate_Aspect
+ (Subt, Has_Static_Predicate_Aspect (Par));
+ Set_Has_Dynamic_Predicate_Aspect
+ (Subt, Has_Dynamic_Predicate_Aspect (Par));
+ end Inherit_Predicate_Flags;
- if not Is_Discrete_Type (T) then
- Error_Msg_N ("discrete type required for range", N);
- Set_Etype (N, Any_Type);
- return;
+ -----------------------
+ -- Is_Null_Extension --
+ -----------------------
- elsif T = Any_Type then
- Set_Etype (N, Any_Type);
- return;
+ function Is_Null_Extension (T : Entity_Id) return Boolean is
+ Type_Decl : constant Node_Id := Parent (Base_Type (T));
+ Comp_List : Node_Id;
+ Comp : Node_Id;
+
+ begin
+ if Nkind (Type_Decl) /= N_Full_Type_Declaration
+ or else not Is_Tagged_Type (T)
+ or else Nkind (Type_Definition (Type_Decl)) /=
+ N_Derived_Type_Definition
+ or else No (Record_Extension_Part (Type_Definition (Type_Decl)))
+ then
+ return False;
end if;
- -- We will now create the appropriate Itype to describe the range, but
- -- first a check. If we originally had a subtype, then we just label
- -- the range with this subtype. Not only is there no need to construct
- -- a new subtype, but it is wrong to do so for two reasons:
+ Comp_List :=
+ Component_List (Record_Extension_Part (Type_Definition (Type_Decl)));
- -- 1. A legality concern, if we have a subtype, it must not freeze,
- -- and the Itype would cause freezing incorrectly
+ if Present (Discriminant_Specifications (Type_Decl)) then
+ return False;
- -- 2. An efficiency concern, if we created an Itype, it would not be
- -- recognized as the same type for the purposes of eliminating
- -- checks in some circumstances.
+ elsif Present (Comp_List)
+ and then Is_Non_Empty_List (Component_Items (Comp_List))
+ then
+ Comp := First (Component_Items (Comp_List));
- -- We signal this case by setting the subtype entity in Def_Id
+ -- Only user-defined components are relevant. The component list
+ -- may also contain a parent component and internal components
+ -- corresponding to secondary tags, but these do not determine
+ -- whether this is a null extension.
- if No (Def_Id) then
- Def_Id :=
- Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
- Set_Etype (Def_Id, Base_Type (T));
+ while Present (Comp) loop
+ if Comes_From_Source (Comp) then
+ return False;
+ end if;
- if Is_Signed_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+ Next (Comp);
+ end loop;
- elsif Is_Modular_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+ return True;
+ else
+ return True;
+ end if;
+ end Is_Null_Extension;
- else
- Set_Ekind (Def_Id, E_Enumeration_Subtype);
- Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
- Set_First_Literal (Def_Id, First_Literal (T));
- end if;
+ ------------------------------
+ -- Is_Valid_Constraint_Kind --
+ ------------------------------
- Set_Size_Info (Def_Id, (T));
- Set_RM_Size (Def_Id, RM_Size (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ function Is_Valid_Constraint_Kind
+ (T_Kind : Type_Kind;
+ Constraint_Kind : Node_Kind) return Boolean
+ is
+ begin
+ case T_Kind is
+ when Enumeration_Kind |
+ Integer_Kind =>
+ return Constraint_Kind = N_Range_Constraint;
- Set_Scalar_Range (Def_Id, R);
- Conditional_Delay (Def_Id, T);
+ when Decimal_Fixed_Point_Kind =>
+ return Nkind_In (Constraint_Kind, N_Digits_Constraint,
+ N_Range_Constraint);
- if Nkind (N) = N_Subtype_Indication then
- Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N)));
- end if;
+ when Ordinary_Fixed_Point_Kind =>
+ return Nkind_In (Constraint_Kind, N_Delta_Constraint,
+ N_Range_Constraint);
- -- In the subtype indication case, if the immediate parent of the
- -- new subtype is non-static, then the subtype we create is non-
- -- static, even if its bounds are static.
+ when Float_Kind =>
+ return Nkind_In (Constraint_Kind, N_Digits_Constraint,
+ N_Range_Constraint);
- if Nkind (N) = N_Subtype_Indication
- and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
- then
- Set_Is_Non_Static_Subtype (Def_Id);
- end if;
- end if;
+ when Access_Kind |
+ Array_Kind |
+ E_Record_Type |
+ E_Record_Subtype |
+ Class_Wide_Kind |
+ E_Incomplete_Type |
+ Private_Kind |
+ Concurrent_Kind =>
+ return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
- -- Final step is to label the index with this constructed type
+ when others =>
+ return True; -- Error will be detected later
+ end case;
+ end Is_Valid_Constraint_Kind;
- Set_Etype (N, Def_Id);
- end Make_Index;
+ --------------------------
+ -- Is_Visible_Component --
+ --------------------------
- ------------------------------
- -- Modular_Type_Declaration --
- ------------------------------
+ function Is_Visible_Component
+ (C : Entity_Id;
+ N : Node_Id := Empty) return Boolean
+ is
+ Original_Comp : Entity_Id := Empty;
+ Original_Scope : Entity_Id;
+ Type_Scope : Entity_Id;
- procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
- Mod_Expr : constant Node_Id := Expression (Def);
- M_Val : Uint;
+ function Is_Local_Type (Typ : Entity_Id) return Boolean;
+ -- Check whether parent type of inherited component is declared locally,
+ -- possibly within a nested package or instance. The current scope is
+ -- the derived record itself.
- procedure Set_Modular_Size (Bits : Int);
- -- Sets RM_Size to Bits, and Esize to normal word size above this
+ -------------------
+ -- Is_Local_Type --
+ -------------------
- ----------------------
- -- Set_Modular_Size --
- ----------------------
+ function Is_Local_Type (Typ : Entity_Id) return Boolean is
+ Scop : Entity_Id;
- procedure Set_Modular_Size (Bits : Int) is
begin
- Set_RM_Size (T, UI_From_Int (Bits));
+ Scop := Scope (Typ);
+ while Present (Scop)
+ and then Scop /= Standard_Standard
+ loop
+ if Scop = Scope (Current_Scope) then
+ return True;
+ end if;
- if Bits <= 8 then
- Init_Esize (T, 8);
+ Scop := Scope (Scop);
+ end loop;
- elsif Bits <= 16 then
- Init_Esize (T, 16);
+ return False;
+ end Is_Local_Type;
- elsif Bits <= 32 then
- Init_Esize (T, 32);
+ -- Start of processing for Is_Visible_Component
- else
- Init_Esize (T, System_Max_Binary_Modulus_Power);
- end if;
+ begin
+ if Ekind_In (C, E_Component, E_Discriminant) then
+ Original_Comp := Original_Record_Component (C);
+ end if;
- if not Non_Binary_Modulus (T)
- and then Esize (T) = RM_Size (T)
- then
- Set_Is_Known_Valid (T);
- end if;
- end Set_Modular_Size;
+ if No (Original_Comp) then
- -- Start of processing for Modular_Type_Declaration
+ -- Premature usage, or previous error
- begin
- -- If the mod expression is (exactly) 2 * literal, where literal is
- -- 64 or less,then almost certainly the * was meant to be **. Warn.
+ return False;
- if Warn_On_Suspicious_Modulus_Value
- and then Nkind (Mod_Expr) = N_Op_Multiply
- and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal
- and then Intval (Left_Opnd (Mod_Expr)) = Uint_2
- and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal
- and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64
- then
- Error_Msg_N
- ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr);
+ else
+ Original_Scope := Scope (Original_Comp);
+ Type_Scope := Scope (Base_Type (Scope (C)));
end if;
- -- Proceed with analysis of mod expression
+ -- This test only concerns tagged types
- Analyze_And_Resolve (Mod_Expr, Any_Integer);
- Set_Etype (T, T);
- Set_Ekind (T, E_Modular_Integer_Type);
- Init_Alignment (T);
- Set_Is_Constrained (T);
+ if not Is_Tagged_Type (Original_Scope) then
+ return True;
- if not Is_OK_Static_Expression (Mod_Expr) then
- Flag_Non_Static_Expr
- ("non-static expression used for modular type bound!", Mod_Expr);
- M_Val := 2 ** System_Max_Binary_Modulus_Power;
- else
- M_Val := Expr_Value (Mod_Expr);
- end if;
+ -- If it is _Parent or _Tag, there is no visibility issue
+
+ elsif not Comes_From_Source (Original_Comp) then
+ return True;
+
+ -- Discriminants are visible unless the (private) type has unknown
+ -- discriminants. If the discriminant reference is inserted for a
+ -- discriminant check on a full view it is also visible.
+
+ elsif Ekind (Original_Comp) = E_Discriminant
+ and then
+ (not Has_Unknown_Discriminants (Original_Scope)
+ or else (Present (N)
+ and then Nkind (N) = N_Selected_Component
+ and then Nkind (Prefix (N)) = N_Type_Conversion
+ and then not Comes_From_Source (Prefix (N))))
+ then
+ return True;
- if M_Val < 1 then
- Error_Msg_N ("modulus value must be positive", Mod_Expr);
- M_Val := 2 ** System_Max_Binary_Modulus_Power;
- end if;
+ -- In the body of an instantiation, no need to check for the visibility
+ -- of a component.
- if M_Val > 2 ** Standard_Long_Integer_Size then
- Check_Restriction (No_Long_Long_Integers, Mod_Expr);
- end if;
+ elsif In_Instance_Body then
+ return True;
- Set_Modulus (T, M_Val);
+ -- If the component has been declared in an ancestor which is currently
+ -- a private type, then it is not visible. The same applies if the
+ -- component's containing type is not in an open scope and the original
+ -- component's enclosing type is a visible full view of a private type
+ -- (which can occur in cases where an attempt is being made to reference
+ -- a component in a sibling package that is inherited from a visible
+ -- component of a type in an ancestor package; the component in the
+ -- sibling package should not be visible even though the component it
+ -- inherited from is visible). This does not apply however in the case
+ -- where the scope of the type is a private child unit, or when the
+ -- parent comes from a local package in which the ancestor is currently
+ -- visible. The latter suppression of visibility is needed for cases
+ -- that are tested in B730006.
- -- Create bounds for the modular type based on the modulus given in
- -- the type declaration and then analyze and resolve those bounds.
+ elsif Is_Private_Type (Original_Scope)
+ or else
+ (not Is_Private_Descendant (Type_Scope)
+ and then not In_Open_Scopes (Type_Scope)
+ and then Has_Private_Declaration (Original_Scope))
+ then
+ -- If the type derives from an entity in a formal package, there
+ -- are no additional visible components.
- Set_Scalar_Range (T,
- Make_Range (Sloc (Mod_Expr),
- Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0),
- High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1)));
+ if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) =
+ N_Formal_Package_Declaration
+ then
+ return False;
- -- Properly analyze the literals for the range. We do this manually
- -- because we can't go calling Resolve, since we are resolving these
- -- bounds with the type, and this type is certainly not complete yet.
+ -- if we are not in the private part of the current package, there
+ -- are no additional visible components.
- Set_Etype (Low_Bound (Scalar_Range (T)), T);
- Set_Etype (High_Bound (Scalar_Range (T)), T);
- Set_Is_Static_Expression (Low_Bound (Scalar_Range (T)));
- Set_Is_Static_Expression (High_Bound (Scalar_Range (T)));
+ elsif Ekind (Scope (Current_Scope)) = E_Package
+ and then not In_Private_Part (Scope (Current_Scope))
+ then
+ return False;
+ else
+ return
+ Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
+ and then In_Open_Scopes (Scope (Original_Scope))
+ and then Is_Local_Type (Type_Scope);
+ end if;
- -- Loop through powers of two to find number of bits required
+ -- There is another weird way in which a component may be invisible when
+ -- the private and the full view are not derived from the same ancestor.
+ -- Here is an example :
- for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop
+ -- type A1 is tagged record F1 : integer; end record;
+ -- type A2 is new A1 with record F2 : integer; end record;
+ -- type T is new A1 with private;
+ -- private
+ -- type T is new A2 with null record;
- -- Binary case
+ -- In this case, the full view of T inherits F1 and F2 but the private
+ -- view inherits only F1
- if M_Val = 2 ** Bits then
- Set_Modular_Size (Bits);
- return;
+ else
+ declare
+ Ancestor : Entity_Id := Scope (C);
- -- Non-binary case
+ begin
+ loop
+ if Ancestor = Original_Scope then
+ return True;
+ elsif Ancestor = Etype (Ancestor) then
+ return False;
+ end if;
- elsif M_Val < 2 ** Bits then
- Check_SPARK_05_Restriction ("modulus should be a power of 2", T);
- Set_Non_Binary_Modulus (T);
+ Ancestor := Etype (Ancestor);
+ end loop;
+ end;
+ end if;
+ end Is_Visible_Component;
- if Bits > System_Max_Nonbinary_Modulus_Power then
- Error_Msg_Uint_1 :=
- UI_From_Int (System_Max_Nonbinary_Modulus_Power);
- Error_Msg_F
- ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
- Set_Modular_Size (System_Max_Binary_Modulus_Power);
- return;
+ --------------------------
+ -- Make_Class_Wide_Type --
+ --------------------------
- else
- -- In the non-binary case, set size as per RM 13.3(55)
+ procedure Make_Class_Wide_Type (T : Entity_Id) is
+ CW_Type : Entity_Id;
+ CW_Name : Name_Id;
+ Next_E : Entity_Id;
- Set_Modular_Size (Bits);
- return;
- end if;
- end if;
+ begin
+ if Present (Class_Wide_Type (T)) then
- end loop;
+ -- The class-wide type is a partially decorated entity created for a
+ -- unanalyzed tagged type referenced through a limited with clause.
+ -- When the tagged type is analyzed, its class-wide type needs to be
+ -- redecorated. Note that we reuse the entity created by Decorate_
+ -- Tagged_Type in order to preserve all links.
- -- If we fall through, then the size exceed System.Max_Binary_Modulus
- -- so we just signal an error and set the maximum size.
+ if Materialize_Entity (Class_Wide_Type (T)) then
+ CW_Type := Class_Wide_Type (T);
+ Set_Materialize_Entity (CW_Type, False);
- Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
- Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
+ -- The class wide type can have been defined by the partial view, in
+ -- which case everything is already done.
- Set_Modular_Size (System_Max_Binary_Modulus_Power);
- Init_Alignment (T);
+ else
+ return;
+ end if;
- end Modular_Type_Declaration;
+ -- Default case, we need to create a new class-wide type
- --------------------------
- -- New_Concatenation_Op --
- --------------------------
+ else
+ CW_Type :=
+ New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');
+ end if;
- procedure New_Concatenation_Op (Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (Typ);
- Op : Entity_Id;
+ -- Inherit root type characteristics
- function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
- -- Create abbreviated declaration for the formal of a predefined
- -- Operator 'Op' of type 'Typ'
+ CW_Name := Chars (CW_Type);
+ Next_E := Next_Entity (CW_Type);
+ Copy_Node (T, CW_Type);
+ Set_Comes_From_Source (CW_Type, False);
+ Set_Chars (CW_Type, CW_Name);
+ Set_Parent (CW_Type, Parent (T));
+ Set_Next_Entity (CW_Type, Next_E);
- --------------------
- -- Make_Op_Formal --
- --------------------
+ -- Ensure we have a new freeze node for the class-wide type. The partial
+ -- view may have freeze action of its own, requiring a proper freeze
+ -- node, and the same freeze node cannot be shared between the two
+ -- types.
- function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
- Formal : Entity_Id;
- begin
- Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
- Set_Etype (Formal, Typ);
- Set_Mechanism (Formal, Default_Mechanism);
- return Formal;
- end Make_Op_Formal;
+ Set_Has_Delayed_Freeze (CW_Type);
+ Set_Freeze_Node (CW_Type, Empty);
- -- Start of processing for New_Concatenation_Op
+ -- Customize the class-wide type: It has no prim. op., it cannot be
+ -- abstract and its Etype points back to the specific root type.
- begin
- Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat);
+ Set_Ekind (CW_Type, E_Class_Wide_Type);
+ Set_Is_Tagged_Type (CW_Type, True);
+ Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List);
+ Set_Is_Abstract_Type (CW_Type, False);
+ Set_Is_Constrained (CW_Type, False);
+ Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
+ Set_Default_SSO (CW_Type);
- Set_Ekind (Op, E_Operator);
- Set_Scope (Op, Current_Scope);
- Set_Etype (Op, Typ);
- Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat));
- Set_Is_Immediately_Visible (Op);
- Set_Is_Intrinsic_Subprogram (Op);
- Set_Has_Completion (Op);
- Append_Entity (Op, Current_Scope);
+ if Ekind (T) = E_Class_Wide_Subtype then
+ Set_Etype (CW_Type, Etype (Base_Type (T)));
+ else
+ Set_Etype (CW_Type, T);
+ end if;
- Set_Name_Entity_Id (Name_Op_Concat, Op);
+ -- If this is the class_wide type of a constrained subtype, it does
+ -- not have discriminants.
- Append_Entity (Make_Op_Formal (Typ, Op), Op);
- Append_Entity (Make_Op_Formal (Typ, Op), Op);
- end New_Concatenation_Op;
+ Set_Has_Discriminants (CW_Type,
+ Has_Discriminants (T) and then not Is_Constrained (T));
- -------------------------
- -- OK_For_Limited_Init --
- -------------------------
+ Set_Has_Unknown_Discriminants (CW_Type, True);
+ Set_Class_Wide_Type (T, CW_Type);
+ Set_Equivalent_Type (CW_Type, Empty);
- -- ???Check all calls of this, and compare the conditions under which it's
- -- called.
+ -- The class-wide type of a class-wide type is itself (RM 3.9(14))
- function OK_For_Limited_Init
- (Typ : Entity_Id;
- Exp : Node_Id) return Boolean
- is
- begin
- return Is_CPP_Constructor_Call (Exp)
- or else (Ada_Version >= Ada_2005
- and then not Debug_Flag_Dot_L
- and then OK_For_Limited_Init_In_05 (Typ, Exp));
- end OK_For_Limited_Init;
+ Set_Class_Wide_Type (CW_Type, CW_Type);
+ end Make_Class_Wide_Type;
- -------------------------------
- -- OK_For_Limited_Init_In_05 --
- -------------------------------
+ ----------------
+ -- Make_Index --
+ ----------------
- function OK_For_Limited_Init_In_05
- (Typ : Entity_Id;
- Exp : Node_Id) return Boolean
+ procedure Make_Index
+ (N : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Suffix_Index : Nat := 1;
+ In_Iter_Schm : Boolean := False)
is
+ R : Node_Id;
+ T : Entity_Id;
+ Def_Id : Entity_Id := Empty;
+ Found : Boolean := False;
+
begin
- -- An object of a limited interface type can be initialized with any
- -- expression of a nonlimited descendant type.
+ -- For a discrete range used in a constrained array definition and
+ -- defined by a range, an implicit conversion to the predefined type
+ -- INTEGER is assumed if each bound is either a numeric literal, a named
+ -- number, or an attribute, and the type of both bounds (prior to the
+ -- implicit conversion) is the type universal_integer. Otherwise, both
+ -- bounds must be of the same discrete type, other than universal
+ -- integer; this type must be determinable independently of the
+ -- context, but using the fact that the type must be discrete and that
+ -- both bounds must have the same type.
- if Is_Class_Wide_Type (Typ)
- and then Is_Limited_Interface (Typ)
- and then not Is_Limited_Type (Etype (Exp))
- then
- return True;
- end if;
+ -- Character literals also have a universal type in the absence of
+ -- of additional context, and are resolved to Standard_Character.
- -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
- -- case of limited aggregates (including extension aggregates), and
- -- function calls. The function call may have been given in prefixed
- -- notation, in which case the original node is an indexed component.
- -- If the function is parameterless, the original node was an explicit
- -- dereference. The function may also be parameterless, in which case
- -- the source node is just an identifier.
+ if Nkind (N) = N_Range then
- case Nkind (Original_Node (Exp)) is
- when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
- return True;
+ -- The index is given by a range constraint. The bounds are known
+ -- to be of a consistent type.
- when N_Identifier =>
- return Present (Entity (Original_Node (Exp)))
- and then Ekind (Entity (Original_Node (Exp))) = E_Function;
+ if not Is_Overloaded (N) then
+ T := Etype (N);
- when N_Qualified_Expression =>
- return
- OK_For_Limited_Init_In_05
- (Typ, Expression (Original_Node (Exp)));
+ -- For universal bounds, choose the specific predefined type
- -- Ada 2005 (AI-251): If a class-wide interface object is initialized
- -- with a function call, the expander has rewritten the call into an
- -- N_Type_Conversion node to force displacement of the pointer to
- -- reference the component containing the secondary dispatch table.
- -- Otherwise a type conversion is not a legal context.
- -- A return statement for a build-in-place function returning a
- -- synchronized type also introduces an unchecked conversion.
+ if T = Universal_Integer then
+ T := Standard_Integer;
- when N_Type_Conversion |
- N_Unchecked_Type_Conversion =>
- return not Comes_From_Source (Exp)
- and then
- OK_For_Limited_Init_In_05
- (Typ, Expression (Original_Node (Exp)));
+ elsif T = Any_Character then
+ Ambiguous_Character (Low_Bound (N));
- when N_Indexed_Component |
- N_Selected_Component |
- N_Explicit_Dereference =>
- return Nkind (Exp) = N_Function_Call;
+ T := Standard_Character;
+ end if;
- -- A use of 'Input is a function call, hence allowed. Normally the
- -- attribute will be changed to a call, but the attribute by itself
- -- can occur with -gnatc.
+ -- The node may be overloaded because some user-defined operators
+ -- are available, but if a universal interpretation exists it is
+ -- also the selected one.
- when N_Attribute_Reference =>
- return Attribute_Name (Original_Node (Exp)) = Name_Input;
+ elsif Universal_Interpretation (N) = Universal_Integer then
+ T := Standard_Integer;
- -- For a case expression, all dependent expressions must be legal
+ else
+ T := Any_Type;
- when N_Case_Expression =>
declare
- Alt : Node_Id;
+ Ind : Interp_Index;
+ It : Interp;
begin
- Alt := First (Alternatives (Original_Node (Exp)));
- while Present (Alt) loop
- if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then
- return False;
+ Get_First_Interp (N, Ind, It);
+ while Present (It.Typ) loop
+ if Is_Discrete_Type (It.Typ) then
+
+ if Found
+ and then not Covers (It.Typ, T)
+ and then not Covers (T, It.Typ)
+ then
+ Error_Msg_N ("ambiguous bounds in discrete range", N);
+ exit;
+ else
+ T := It.Typ;
+ Found := True;
+ end if;
end if;
- Next (Alt);
+ Get_Next_Interp (Ind, It);
end loop;
- return True;
- end;
-
- -- For an if expression, all dependent expressions must be legal
+ if T = Any_Type then
+ Error_Msg_N ("discrete type required for range", N);
+ Set_Etype (N, Any_Type);
+ return;
- when N_If_Expression =>
- declare
- Then_Expr : constant Node_Id :=
- Next (First (Expressions (Original_Node (Exp))));
- Else_Expr : constant Node_Id := Next (Then_Expr);
- begin
- return OK_For_Limited_Init_In_05 (Typ, Then_Expr)
- and then
- OK_For_Limited_Init_In_05 (Typ, Else_Expr);
+ elsif T = Universal_Integer then
+ T := Standard_Integer;
+ end if;
end;
+ end if;
- when others =>
- return False;
- end case;
- end OK_For_Limited_Init_In_05;
+ if not Is_Discrete_Type (T) then
+ Error_Msg_N ("discrete type required for range", N);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
- -------------------------------------------
- -- Ordinary_Fixed_Point_Type_Declaration --
- -------------------------------------------
+ if Nkind (Low_Bound (N)) = N_Attribute_Reference
+ and then Attribute_Name (Low_Bound (N)) = Name_First
+ and then Is_Entity_Name (Prefix (Low_Bound (N)))
+ and then Is_Type (Entity (Prefix (Low_Bound (N))))
+ and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N))))
+ then
+ -- The type of the index will be the type of the prefix, as long
+ -- as the upper bound is 'Last of the same type.
- procedure Ordinary_Fixed_Point_Type_Declaration
- (T : Entity_Id;
- Def : Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (Def);
- Delta_Expr : constant Node_Id := Delta_Expression (Def);
- RRS : constant Node_Id := Real_Range_Specification (Def);
- Implicit_Base : Entity_Id;
- Delta_Val : Ureal;
- Small_Val : Ureal;
- Low_Val : Ureal;
- High_Val : Ureal;
+ Def_Id := Entity (Prefix (Low_Bound (N)));
- begin
- Check_Restriction (No_Fixed_Point, Def);
+ if Nkind (High_Bound (N)) /= N_Attribute_Reference
+ or else Attribute_Name (High_Bound (N)) /= Name_Last
+ or else not Is_Entity_Name (Prefix (High_Bound (N)))
+ or else Entity (Prefix (High_Bound (N))) /= Def_Id
+ then
+ Def_Id := Empty;
+ end if;
+ end if;
- -- Create implicit base type
+ R := N;
+ Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm);
- Implicit_Base :=
- Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
- Set_Etype (Implicit_Base, Implicit_Base);
+ elsif Nkind (N) = N_Subtype_Indication then
- -- Analyze and process delta expression
+ -- The index is given by a subtype with a range constraint
- Analyze_And_Resolve (Delta_Expr, Any_Real);
+ T := Base_Type (Entity (Subtype_Mark (N)));
- Check_Delta_Expression (Delta_Expr);
- Delta_Val := Expr_Value_R (Delta_Expr);
+ if not Is_Discrete_Type (T) then
+ Error_Msg_N ("discrete type required for range", N);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
- Set_Delta_Value (Implicit_Base, Delta_Val);
+ R := Range_Expression (Constraint (N));
- -- Compute default small from given delta, which is the largest power
- -- of two that does not exceed the given delta value.
+ Resolve (R, T);
+ Process_Range_Expr_In_Decl
+ (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm);
- declare
- Tmp : Ureal;
- Scale : Int;
+ elsif Nkind (N) = N_Attribute_Reference then
- begin
- Tmp := Ureal_1;
- Scale := 0;
+ -- Catch beginner's error (use of attribute other than 'Range)
- if Delta_Val < Ureal_1 then
- while Delta_Val < Tmp loop
- Tmp := Tmp / Ureal_2;
- Scale := Scale + 1;
- end loop;
+ if Attribute_Name (N) /= Name_Range then
+ Error_Msg_N ("expect attribute ''Range", N);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
- else
- loop
- Tmp := Tmp * Ureal_2;
- exit when Tmp > Delta_Val;
- Scale := Scale - 1;
- end loop;
+ -- If the node denotes the range of a type mark, that is also the
+ -- resulting type, and we do not need to create an Itype for it.
+
+ if Is_Entity_Name (Prefix (N))
+ and then Comes_From_Source (N)
+ and then Is_Type (Entity (Prefix (N)))
+ and then Is_Discrete_Type (Entity (Prefix (N)))
+ then
+ Def_Id := Entity (Prefix (N));
end if;
- Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
- end;
+ Analyze_And_Resolve (N);
+ T := Etype (N);
+ R := N;
- Set_Small_Value (Implicit_Base, Small_Val);
+ -- If none of the above, must be a subtype. We convert this to a
+ -- range attribute reference because in the case of declared first
+ -- named subtypes, the types in the range reference can be different
+ -- from the type of the entity. A range attribute normalizes the
+ -- reference and obtains the correct types for the bounds.
+
+ -- This transformation is in the nature of an expansion, is only
+ -- done if expansion is active. In particular, it is not done on
+ -- formal generic types, because we need to retain the name of the
+ -- original index for instantiation purposes.
+
+ else
+ if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then
+ Error_Msg_N ("invalid subtype mark in discrete range ", N);
+ Set_Etype (N, Any_Integer);
+ return;
+
+ else
+ -- The type mark may be that of an incomplete type. It is only
+ -- now that we can get the full view, previous analysis does
+ -- not look specifically for a type mark.
+
+ Set_Entity (N, Get_Full_View (Entity (N)));
+ Set_Etype (N, Entity (N));
+ Def_Id := Entity (N);
- -- If no range was given, set a dummy range
+ if not Is_Discrete_Type (Def_Id) then
+ Error_Msg_N ("discrete type required for index", N);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+ end if;
- if RRS <= Empty_Or_Error then
- Low_Val := -Small_Val;
- High_Val := Small_Val;
+ if Expander_Active then
+ Rewrite (N,
+ Make_Attribute_Reference (Sloc (N),
+ Attribute_Name => Name_Range,
+ Prefix => Relocate_Node (N)));
- -- Otherwise analyze and process given range
+ -- The original was a subtype mark that does not freeze. This
+ -- means that the rewritten version must not freeze either.
- else
- declare
- Low : constant Node_Id := Low_Bound (RRS);
- High : constant Node_Id := High_Bound (RRS);
+ Set_Must_Not_Freeze (N);
+ Set_Must_Not_Freeze (Prefix (N));
+ Analyze_And_Resolve (N);
+ T := Etype (N);
+ R := N;
- begin
- Analyze_And_Resolve (Low, Any_Real);
- Analyze_And_Resolve (High, Any_Real);
- Check_Real_Bound (Low);
- Check_Real_Bound (High);
+ -- If expander is inactive, type is legal, nothing else to construct
- -- Obtain and set the range
+ else
+ return;
+ end if;
+ end if;
- Low_Val := Expr_Value_R (Low);
- High_Val := Expr_Value_R (High);
+ if not Is_Discrete_Type (T) then
+ Error_Msg_N ("discrete type required for range", N);
+ Set_Etype (N, Any_Type);
+ return;
- if Low_Val > High_Val then
- Error_Msg_NE ("??fixed point type& has null range", Def, T);
- end if;
- end;
+ elsif T = Any_Type then
+ Set_Etype (N, Any_Type);
+ return;
end if;
- -- The range for both the implicit base and the declared first subtype
- -- cannot be set yet, so we use the special routine Set_Fixed_Range to
- -- set a temporary range in place. Note that the bounds of the base
- -- type will be widened to be symmetrical and to fill the available
- -- bits when the type is frozen.
+ -- We will now create the appropriate Itype to describe the range, but
+ -- first a check. If we originally had a subtype, then we just label
+ -- the range with this subtype. Not only is there no need to construct
+ -- a new subtype, but it is wrong to do so for two reasons:
- -- We could do this with all discrete types, and probably should, but
- -- we absolutely have to do it for fixed-point, since the end-points
- -- of the range and the size are determined by the small value, which
- -- could be reset before the freeze point.
+ -- 1. A legality concern, if we have a subtype, it must not freeze,
+ -- and the Itype would cause freezing incorrectly
- Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
- Set_Fixed_Range (T, Loc, Low_Val, High_Val);
+ -- 2. An efficiency concern, if we created an Itype, it would not be
+ -- recognized as the same type for the purposes of eliminating
+ -- checks in some circumstances.
- -- Complete definition of first subtype
+ -- We signal this case by setting the subtype entity in Def_Id
- Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
- Set_Etype (T, Implicit_Base);
- Init_Size_Align (T);
- Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
- Set_Small_Value (T, Small_Val);
- Set_Delta_Value (T, Delta_Val);
- Set_Is_Constrained (T);
+ if No (Def_Id) then
+ Def_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index);
+ Set_Etype (Def_Id, Base_Type (T));
- end Ordinary_Fixed_Point_Type_Declaration;
+ if Is_Signed_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
- ----------------------------------------
- -- Prepare_Private_Subtype_Completion --
- ----------------------------------------
+ elsif Is_Modular_Integer_Type (T) then
+ Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
- procedure Prepare_Private_Subtype_Completion
- (Id : Entity_Id;
- Related_Nod : Node_Id)
- is
- Id_B : constant Entity_Id := Base_Type (Id);
- Full_B : Entity_Id := Full_View (Id_B);
- Full : Entity_Id;
+ else
+ Set_Ekind (Def_Id, E_Enumeration_Subtype);
+ Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+ Set_First_Literal (Def_Id, First_Literal (T));
+ end if;
- begin
- if Present (Full_B) then
+ Set_Size_Info (Def_Id, (T));
+ Set_RM_Size (Def_Id, RM_Size (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- -- Get to the underlying full view if necessary
+ Set_Scalar_Range (Def_Id, R);
+ Conditional_Delay (Def_Id, T);
- if Is_Private_Type (Full_B)
- and then Present (Underlying_Full_View (Full_B))
- then
- Full_B := Underlying_Full_View (Full_B);
+ if Nkind (N) = N_Subtype_Indication then
+ Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N)));
end if;
- -- The Base_Type is already completed, we can complete the subtype
- -- now. We have to create a new entity with the same name, Thus we
- -- can't use Create_Itype.
+ -- In the subtype indication case, if the immediate parent of the
+ -- new subtype is non-static, then the subtype we create is non-
+ -- static, even if its bounds are static.
- Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));
- Set_Is_Itype (Full);
- Set_Associated_Node_For_Itype (Full, Related_Nod);
- Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);
+ if Nkind (N) = N_Subtype_Indication
+ and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
+ then
+ Set_Is_Non_Static_Subtype (Def_Id);
+ end if;
end if;
- -- The parent subtype may be private, but the base might not, in some
- -- nested instances. In that case, the subtype does not need to be
- -- exchanged. It would still be nice to make private subtypes and their
- -- bases consistent at all times ???
+ -- Final step is to label the index with this constructed type
- if Is_Private_Type (Id_B) then
- Append_Elmt (Id, Private_Dependents (Id_B));
- end if;
- end Prepare_Private_Subtype_Completion;
+ Set_Etype (N, Def_Id);
+ end Make_Index;
- ---------------------------
- -- Process_Discriminants --
- ---------------------------
+ ------------------------------
+ -- Modular_Type_Declaration --
+ ------------------------------
- procedure Process_Discriminants
- (N : Node_Id;
- Prev : Entity_Id := Empty)
- is
- Elist : constant Elist_Id := New_Elmt_List;
- Id : Node_Id;
- Discr : Node_Id;
- Discr_Number : Uint;
- Discr_Type : Entity_Id;
- Default_Present : Boolean := False;
- Default_Not_Present : Boolean := False;
+ procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
+ Mod_Expr : constant Node_Id := Expression (Def);
+ M_Val : Uint;
- begin
- -- A composite type other than an array type can have discriminants.
- -- On entry, the current scope is the composite type.
+ procedure Set_Modular_Size (Bits : Int);
+ -- Sets RM_Size to Bits, and Esize to normal word size above this
- -- The discriminants are initially entered into the scope of the type
- -- via Enter_Name with the default Ekind of E_Void to prevent premature
- -- use, as explained at the end of this procedure.
+ ----------------------
+ -- Set_Modular_Size --
+ ----------------------
- Discr := First (Discriminant_Specifications (N));
- while Present (Discr) loop
- Enter_Name (Defining_Identifier (Discr));
+ procedure Set_Modular_Size (Bits : Int) is
+ begin
+ Set_RM_Size (T, UI_From_Int (Bits));
- -- For navigation purposes we add a reference to the discriminant
- -- in the entity for the type. If the current declaration is a
- -- completion, place references on the partial view. Otherwise the
- -- type is the current scope.
+ if Bits <= 8 then
+ Init_Esize (T, 8);
- if Present (Prev) then
+ elsif Bits <= 16 then
+ Init_Esize (T, 16);
- -- The references go on the partial view, if present. If the
- -- partial view has discriminants, the references have been
- -- generated already.
+ elsif Bits <= 32 then
+ Init_Esize (T, 32);
- if not Has_Discriminants (Prev) then
- Generate_Reference (Prev, Defining_Identifier (Discr), 'd');
- end if;
else
- Generate_Reference
- (Current_Scope, Defining_Identifier (Discr), 'd');
+ Init_Esize (T, System_Max_Binary_Modulus_Power);
end if;
- if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
- Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
+ if not Non_Binary_Modulus (T)
+ and then Esize (T) = RM_Size (T)
+ then
+ Set_Is_Known_Valid (T);
+ end if;
+ end Set_Modular_Size;
- -- Ada 2005 (AI-254)
+ -- Start of processing for Modular_Type_Declaration
- if Present (Access_To_Subprogram_Definition
- (Discriminant_Type (Discr)))
- and then Protected_Present (Access_To_Subprogram_Definition
- (Discriminant_Type (Discr)))
- then
- Discr_Type :=
- Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
- end if;
+ begin
+ -- If the mod expression is (exactly) 2 * literal, where literal is
+ -- 64 or less,then almost certainly the * was meant to be **. Warn.
+
+ if Warn_On_Suspicious_Modulus_Value
+ and then Nkind (Mod_Expr) = N_Op_Multiply
+ and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal
+ and then Intval (Left_Opnd (Mod_Expr)) = Uint_2
+ and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal
+ and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64
+ then
+ Error_Msg_N
+ ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr);
+ end if;
+
+ -- Proceed with analysis of mod expression
+
+ Analyze_And_Resolve (Mod_Expr, Any_Integer);
+ Set_Etype (T, T);
+ Set_Ekind (T, E_Modular_Integer_Type);
+ Init_Alignment (T);
+ Set_Is_Constrained (T);
+
+ if not Is_OK_Static_Expression (Mod_Expr) then
+ Flag_Non_Static_Expr
+ ("non-static expression used for modular type bound!", Mod_Expr);
+ M_Val := 2 ** System_Max_Binary_Modulus_Power;
+ else
+ M_Val := Expr_Value (Mod_Expr);
+ end if;
+
+ if M_Val < 1 then
+ Error_Msg_N ("modulus value must be positive", Mod_Expr);
+ M_Val := 2 ** System_Max_Binary_Modulus_Power;
+ end if;
- else
- Find_Type (Discriminant_Type (Discr));
- Discr_Type := Etype (Discriminant_Type (Discr));
+ if M_Val > 2 ** Standard_Long_Integer_Size then
+ Check_Restriction (No_Long_Long_Integers, Mod_Expr);
+ end if;
- if Error_Posted (Discriminant_Type (Discr)) then
- Discr_Type := Any_Type;
- end if;
- end if;
+ Set_Modulus (T, M_Val);
- -- Handling of discriminants that are access types
+ -- Create bounds for the modular type based on the modulus given in
+ -- the type declaration and then analyze and resolve those bounds.
- if Is_Access_Type (Discr_Type) then
+ Set_Scalar_Range (T,
+ Make_Range (Sloc (Mod_Expr),
+ Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0),
+ High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1)));
- -- Ada 2005 (AI-230): Access discriminant allowed in non-
- -- limited record types
+ -- Properly analyze the literals for the range. We do this manually
+ -- because we can't go calling Resolve, since we are resolving these
+ -- bounds with the type, and this type is certainly not complete yet.
- if Ada_Version < Ada_2005 then
- Check_Access_Discriminant_Requires_Limited
- (Discr, Discriminant_Type (Discr));
- end if;
+ Set_Etype (Low_Bound (Scalar_Range (T)), T);
+ Set_Etype (High_Bound (Scalar_Range (T)), T);
+ Set_Is_Static_Expression (Low_Bound (Scalar_Range (T)));
+ Set_Is_Static_Expression (High_Bound (Scalar_Range (T)));
- if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then
- Error_Msg_N
- ("(Ada 83) access discriminant not allowed", Discr);
- end if;
+ -- Loop through powers of two to find number of bits required
- -- If not access type, must be a discrete type
+ for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop
- elsif not Is_Discrete_Type (Discr_Type) then
- Error_Msg_N
- ("discriminants must have a discrete or access type",
- Discriminant_Type (Discr));
- end if;
+ -- Binary case
- Set_Etype (Defining_Identifier (Discr), Discr_Type);
+ if M_Val = 2 ** Bits then
+ Set_Modular_Size (Bits);
+ return;
- -- If a discriminant specification includes the assignment compound
- -- delimiter followed by an expression, the expression is the default
- -- expression of the discriminant; the default expression must be of
- -- the type of the discriminant. (RM 3.7.1) Since this expression is
- -- a default expression, we do the special preanalysis, since this
- -- expression does not freeze (see section "Handling of Default and
- -- Per-Object Expressions" in spec of package Sem).
+ -- Non-binary case
- if Present (Expression (Discr)) then
- Preanalyze_Spec_Expression (Expression (Discr), Discr_Type);
+ elsif M_Val < 2 ** Bits then
+ Check_SPARK_05_Restriction ("modulus should be a power of 2", T);
+ Set_Non_Binary_Modulus (T);
- -- Legaity checks
+ if Bits > System_Max_Nonbinary_Modulus_Power then
+ Error_Msg_Uint_1 :=
+ UI_From_Int (System_Max_Nonbinary_Modulus_Power);
+ Error_Msg_F
+ ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
+ Set_Modular_Size (System_Max_Binary_Modulus_Power);
+ return;
- if Nkind (N) = N_Formal_Type_Declaration then
- Error_Msg_N
- ("discriminant defaults not allowed for formal type",
- Expression (Discr));
+ else
+ -- In the non-binary case, set size as per RM 13.3(55)
- -- Flag an error for a tagged type with defaulted discriminants,
- -- excluding limited tagged types when compiling for Ada 2012
- -- (see AI05-0214).
+ Set_Modular_Size (Bits);
+ return;
+ end if;
+ end if;
- elsif Is_Tagged_Type (Current_Scope)
- and then (not Is_Limited_Type (Current_Scope)
- or else Ada_Version < Ada_2012)
- and then Comes_From_Source (N)
- then
- -- Note: see similar test in Check_Or_Process_Discriminants, to
- -- handle the (illegal) case of the completion of an untagged
- -- view with discriminants with defaults by a tagged full view.
- -- We skip the check if Discr does not come from source, to
- -- account for the case of an untagged derived type providing
- -- defaults for a renamed discriminant from a private untagged
- -- ancestor with a tagged full view (ACATS B460006).
+ end loop;
- if Ada_Version >= Ada_2012 then
- Error_Msg_N
- ("discriminants of nonlimited tagged type cannot have"
- & " defaults",
- Expression (Discr));
- else
- Error_Msg_N
- ("discriminants of tagged type cannot have defaults",
- Expression (Discr));
- end if;
+ -- If we fall through, then the size exceed System.Max_Binary_Modulus
+ -- so we just signal an error and set the maximum size.
- else
- Default_Present := True;
- Append_Elmt (Expression (Discr), Elist);
+ Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
+ Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
- -- Tag the defining identifiers for the discriminants with
- -- their corresponding default expressions from the tree.
+ Set_Modular_Size (System_Max_Binary_Modulus_Power);
+ Init_Alignment (T);
- Set_Discriminant_Default_Value
- (Defining_Identifier (Discr), Expression (Discr));
- end if;
+ end Modular_Type_Declaration;
- -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag
- -- gets set unless we can be sure that no range check is required.
+ --------------------------
+ -- New_Concatenation_Op --
+ --------------------------
- if (GNATprove_Mode or not Expander_Active)
- and then not
- Is_In_Range
- (Expression (Discr), Discr_Type, Assume_Valid => True)
- then
- Set_Do_Range_Check (Expression (Discr));
- end if;
+ procedure New_Concatenation_Op (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Op : Entity_Id;
- -- No default discriminant value given
+ function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
+ -- Create abbreviated declaration for the formal of a predefined
+ -- Operator 'Op' of type 'Typ'
- else
- Default_Not_Present := True;
- end if;
+ --------------------
+ -- Make_Op_Formal --
+ --------------------
- -- Ada 2005 (AI-231): Create an Itype that is a duplicate of
- -- Discr_Type but with the null-exclusion attribute
+ function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is
+ Formal : Entity_Id;
+ begin
+ Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P');
+ Set_Etype (Formal, Typ);
+ Set_Mechanism (Formal, Default_Mechanism);
+ return Formal;
+ end Make_Op_Formal;
- if Ada_Version >= Ada_2005 then
+ -- Start of processing for New_Concatenation_Op
- -- Ada 2005 (AI-231): Static checks
+ begin
+ Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat);
- if Can_Never_Be_Null (Discr_Type) then
- Null_Exclusion_Static_Checks (Discr);
+ Set_Ekind (Op, E_Operator);
+ Set_Scope (Op, Current_Scope);
+ Set_Etype (Op, Typ);
+ Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat));
+ Set_Is_Immediately_Visible (Op);
+ Set_Is_Intrinsic_Subprogram (Op);
+ Set_Has_Completion (Op);
+ Append_Entity (Op, Current_Scope);
- elsif Is_Access_Type (Discr_Type)
- and then Null_Exclusion_Present (Discr)
+ Set_Name_Entity_Id (Name_Op_Concat, Op);
- -- No need to check itypes because in their case this check
- -- was done at their point of creation
+ Append_Entity (Make_Op_Formal (Typ, Op), Op);
+ Append_Entity (Make_Op_Formal (Typ, Op), Op);
+ end New_Concatenation_Op;
- and then not Is_Itype (Discr_Type)
- then
- if Can_Never_Be_Null (Discr_Type) then
- Error_Msg_NE
- ("`NOT NULL` not allowed (& already excludes null)",
- Discr,
- Discr_Type);
- end if;
+ -------------------------
+ -- OK_For_Limited_Init --
+ -------------------------
- Set_Etype (Defining_Identifier (Discr),
- Create_Null_Excluding_Itype
- (T => Discr_Type,
- Related_Nod => Discr));
+ -- ???Check all calls of this, and compare the conditions under which it's
+ -- called.
- -- Check for improper null exclusion if the type is otherwise
- -- legal for a discriminant.
+ function OK_For_Limited_Init
+ (Typ : Entity_Id;
+ Exp : Node_Id) return Boolean
+ is
+ begin
+ return Is_CPP_Constructor_Call (Exp)
+ or else (Ada_Version >= Ada_2005
+ and then not Debug_Flag_Dot_L
+ and then OK_For_Limited_Init_In_05 (Typ, Exp));
+ end OK_For_Limited_Init;
- elsif Null_Exclusion_Present (Discr)
- and then Is_Discrete_Type (Discr_Type)
- then
- Error_Msg_N
- ("null exclusion can only apply to an access type", Discr);
- end if;
+ -------------------------------
+ -- OK_For_Limited_Init_In_05 --
+ -------------------------------
- -- Ada 2005 (AI-402): access discriminants of nonlimited types
- -- can't have defaults. Synchronized types, or types that are
- -- explicitly limited are fine, but special tests apply to derived
- -- types in generics: in a generic body we have to assume the
- -- worst, and therefore defaults are not allowed if the parent is
- -- a generic formal private type (see ACATS B370001).
+ function OK_For_Limited_Init_In_05
+ (Typ : Entity_Id;
+ Exp : Node_Id) return Boolean
+ is
+ begin
+ -- An object of a limited interface type can be initialized with any
+ -- expression of a nonlimited descendant type.
- if Is_Access_Type (Discr_Type) and then Default_Present then
- if Ekind (Discr_Type) /= E_Anonymous_Access_Type
- or else Is_Limited_Record (Current_Scope)
- or else Is_Concurrent_Type (Current_Scope)
- or else Is_Concurrent_Record_Type (Current_Scope)
- or else Ekind (Current_Scope) = E_Limited_Private_Type
- then
- if not Is_Derived_Type (Current_Scope)
- or else not Is_Generic_Type (Etype (Current_Scope))
- or else not In_Package_Body (Scope (Etype (Current_Scope)))
- or else Limited_Present
- (Type_Definition (Parent (Current_Scope)))
- then
- null;
+ if Is_Class_Wide_Type (Typ)
+ and then Is_Limited_Interface (Typ)
+ and then not Is_Limited_Type (Etype (Exp))
+ then
+ return True;
+ end if;
+
+ -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
+ -- case of limited aggregates (including extension aggregates), and
+ -- function calls. The function call may have been given in prefixed
+ -- notation, in which case the original node is an indexed component.
+ -- If the function is parameterless, the original node was an explicit
+ -- dereference. The function may also be parameterless, in which case
+ -- the source node is just an identifier.
- else
- Error_Msg_N ("access discriminants of nonlimited types",
- Expression (Discr));
- Error_Msg_N ("\cannot have defaults", Expression (Discr));
- end if;
+ case Nkind (Original_Node (Exp)) is
+ when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
+ return True;
- elsif Present (Expression (Discr)) then
- Error_Msg_N
- ("(Ada 2005) access discriminants of nonlimited types",
- Expression (Discr));
- Error_Msg_N ("\cannot have defaults", Expression (Discr));
- end if;
- end if;
- end if;
+ when N_Identifier =>
+ return Present (Entity (Original_Node (Exp)))
+ and then Ekind (Entity (Original_Node (Exp))) = E_Function;
- -- A discriminant cannot be effectively volatile. This check is only
- -- relevant when SPARK_Mode is on as it is not standard Ada legality
- -- rule (SPARK RM 7.1.3(6)).
+ when N_Qualified_Expression =>
+ return
+ OK_For_Limited_Init_In_05
+ (Typ, Expression (Original_Node (Exp)));
- if SPARK_Mode = On
- and then Is_Effectively_Volatile (Defining_Identifier (Discr))
- then
- Error_Msg_N ("discriminant cannot be volatile", Discr);
- end if;
+ -- Ada 2005 (AI-251): If a class-wide interface object is initialized
+ -- with a function call, the expander has rewritten the call into an
+ -- N_Type_Conversion node to force displacement of the pointer to
+ -- reference the component containing the secondary dispatch table.
+ -- Otherwise a type conversion is not a legal context.
+ -- A return statement for a build-in-place function returning a
+ -- synchronized type also introduces an unchecked conversion.
- Next (Discr);
- end loop;
+ when N_Type_Conversion |
+ N_Unchecked_Type_Conversion =>
+ return not Comes_From_Source (Exp)
+ and then
+ OK_For_Limited_Init_In_05
+ (Typ, Expression (Original_Node (Exp)));
- -- An element list consisting of the default expressions of the
- -- discriminants is constructed in the above loop and used to set
- -- the Discriminant_Constraint attribute for the type. If an object
- -- is declared of this (record or task) type without any explicit
- -- discriminant constraint given, this element list will form the
- -- actual parameters for the corresponding initialization procedure
- -- for the type.
+ when N_Indexed_Component |
+ N_Selected_Component |
+ N_Explicit_Dereference =>
+ return Nkind (Exp) = N_Function_Call;
- Set_Discriminant_Constraint (Current_Scope, Elist);
- Set_Stored_Constraint (Current_Scope, No_Elist);
+ -- A use of 'Input is a function call, hence allowed. Normally the
+ -- attribute will be changed to a call, but the attribute by itself
+ -- can occur with -gnatc.
- -- Default expressions must be provided either for all or for none
- -- of the discriminants of a discriminant part. (RM 3.7.1)
+ when N_Attribute_Reference =>
+ return Attribute_Name (Original_Node (Exp)) = Name_Input;
- if Default_Present and then Default_Not_Present then
- Error_Msg_N
- ("incomplete specification of defaults for discriminants", N);
- end if;
+ -- For a case expression, all dependent expressions must be legal
- -- The use of the name of a discriminant is not allowed in default
- -- expressions of a discriminant part if the specification of the
- -- discriminant is itself given in the discriminant part. (RM 3.7.1)
+ when N_Case_Expression =>
+ declare
+ Alt : Node_Id;
- -- To detect this, the discriminant names are entered initially with an
- -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
- -- attempt to use a void entity (for example in an expression that is
- -- type-checked) produces the error message: premature usage. Now after
- -- completing the semantic analysis of the discriminant part, we can set
- -- the Ekind of all the discriminants appropriately.
+ begin
+ Alt := First (Alternatives (Original_Node (Exp)));
+ while Present (Alt) loop
+ if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then
+ return False;
+ end if;
- Discr := First (Discriminant_Specifications (N));
- Discr_Number := Uint_1;
- while Present (Discr) loop
- Id := Defining_Identifier (Discr);
- Set_Ekind (Id, E_Discriminant);
- Init_Component_Location (Id);
- Init_Esize (Id);
- Set_Discriminant_Number (Id, Discr_Number);
+ Next (Alt);
+ end loop;
- -- Make sure this is always set, even in illegal programs
+ return True;
+ end;
- Set_Corresponding_Discriminant (Id, Empty);
+ -- For an if expression, all dependent expressions must be legal
- -- Initialize the Original_Record_Component to the entity itself.
- -- Inherit_Components will propagate the right value to
- -- discriminants in derived record types.
+ when N_If_Expression =>
+ declare
+ Then_Expr : constant Node_Id :=
+ Next (First (Expressions (Original_Node (Exp))));
+ Else_Expr : constant Node_Id := Next (Then_Expr);
+ begin
+ return OK_For_Limited_Init_In_05 (Typ, Then_Expr)
+ and then
+ OK_For_Limited_Init_In_05 (Typ, Else_Expr);
+ end;
- Set_Original_Record_Component (Id, Id);
+ when others =>
+ return False;
+ end case;
+ end OK_For_Limited_Init_In_05;
- -- Create the discriminal for the discriminant
+ -------------------------------------------
+ -- Ordinary_Fixed_Point_Type_Declaration --
+ -------------------------------------------
- Build_Discriminal (Id);
+ procedure Ordinary_Fixed_Point_Type_Declaration
+ (T : Entity_Id;
+ Def : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Def);
+ Delta_Expr : constant Node_Id := Delta_Expression (Def);
+ RRS : constant Node_Id := Real_Range_Specification (Def);
+ Implicit_Base : Entity_Id;
+ Delta_Val : Ureal;
+ Small_Val : Ureal;
+ Low_Val : Ureal;
+ High_Val : Ureal;
- Next (Discr);
- Discr_Number := Discr_Number + 1;
- end loop;
+ begin
+ Check_Restriction (No_Fixed_Point, Def);
- Set_Has_Discriminants (Current_Scope);
- end Process_Discriminants;
+ -- Create implicit base type
- -----------------------
- -- Process_Full_View --
- -----------------------
+ Implicit_Base :=
+ Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
+ Set_Etype (Implicit_Base, Implicit_Base);
- procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
- Priv_Parent : Entity_Id;
- Full_Parent : Entity_Id;
- Full_Indic : Node_Id;
+ -- Analyze and process delta expression
- procedure Collect_Implemented_Interfaces
- (Typ : Entity_Id;
- Ifaces : Elist_Id);
- -- Ada 2005: Gather all the interfaces that Typ directly or
- -- inherently implements. Duplicate entries are not added to
- -- the list Ifaces.
+ Analyze_And_Resolve (Delta_Expr, Any_Real);
- ------------------------------------
- -- Collect_Implemented_Interfaces --
- ------------------------------------
+ Check_Delta_Expression (Delta_Expr);
+ Delta_Val := Expr_Value_R (Delta_Expr);
- procedure Collect_Implemented_Interfaces
- (Typ : Entity_Id;
- Ifaces : Elist_Id)
- is
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
+ Set_Delta_Value (Implicit_Base, Delta_Val);
- begin
- -- Abstract interfaces are only associated with tagged record types
+ -- Compute default small from given delta, which is the largest power
+ -- of two that does not exceed the given delta value.
- if not Is_Tagged_Type (Typ)
- or else not Is_Record_Type (Typ)
- then
- return;
- end if;
+ declare
+ Tmp : Ureal;
+ Scale : Int;
- -- Recursively climb to the ancestors
+ begin
+ Tmp := Ureal_1;
+ Scale := 0;
- if Etype (Typ) /= Typ
+ if Delta_Val < Ureal_1 then
+ while Delta_Val < Tmp loop
+ Tmp := Tmp / Ureal_2;
+ Scale := Scale + 1;
+ end loop;
- -- Protect the frontend against wrong cyclic declarations like:
+ else
+ loop
+ Tmp := Tmp * Ureal_2;
+ exit when Tmp > Delta_Val;
+ Scale := Scale - 1;
+ end loop;
+ end if;
- -- type B is new A with private;
- -- type C is new A with private;
- -- private
- -- type B is new C with null record;
- -- type C is new B with null record;
+ Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
+ end;
- and then Etype (Typ) /= Priv_T
- and then Etype (Typ) /= Full_T
- then
- -- Keep separate the management of private type declarations
+ Set_Small_Value (Implicit_Base, Small_Val);
- if Ekind (Typ) = E_Record_Type_With_Private then
+ -- If no range was given, set a dummy range
- -- Handle the following illegal usage:
- -- type Private_Type is tagged private;
- -- private
- -- type Private_Type is new Type_Implementing_Iface;
+ if RRS <= Empty_Or_Error then
+ Low_Val := -Small_Val;
+ High_Val := Small_Val;
- if Present (Full_View (Typ))
- and then Etype (Typ) /= Full_View (Typ)
- then
- if Is_Interface (Etype (Typ)) then
- Append_Unique_Elmt (Etype (Typ), Ifaces);
- end if;
+ -- Otherwise analyze and process given range
- Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
- end if;
+ else
+ declare
+ Low : constant Node_Id := Low_Bound (RRS);
+ High : constant Node_Id := High_Bound (RRS);
- -- Non-private types
+ begin
+ Analyze_And_Resolve (Low, Any_Real);
+ Analyze_And_Resolve (High, Any_Real);
+ Check_Real_Bound (Low);
+ Check_Real_Bound (High);
- else
- if Is_Interface (Etype (Typ)) then
- Append_Unique_Elmt (Etype (Typ), Ifaces);
- end if;
+ -- Obtain and set the range
+
+ Low_Val := Expr_Value_R (Low);
+ High_Val := Expr_Value_R (High);
- Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
+ if Low_Val > High_Val then
+ Error_Msg_NE ("??fixed point type& has null range", Def, T);
end if;
- end if;
+ end;
+ end if;
- -- Handle entities in the list of abstract interfaces
+ -- The range for both the implicit base and the declared first subtype
+ -- cannot be set yet, so we use the special routine Set_Fixed_Range to
+ -- set a temporary range in place. Note that the bounds of the base
+ -- type will be widened to be symmetrical and to fill the available
+ -- bits when the type is frozen.
- if Present (Interfaces (Typ)) then
- Iface_Elmt := First_Elmt (Interfaces (Typ));
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
+ -- We could do this with all discrete types, and probably should, but
+ -- we absolutely have to do it for fixed-point, since the end-points
+ -- of the range and the size are determined by the small value, which
+ -- could be reset before the freeze point.
- pragma Assert (Is_Interface (Iface));
+ Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
+ Set_Fixed_Range (T, Loc, Low_Val, High_Val);
- if not Contain_Interface (Iface, Ifaces) then
- Append_Elmt (Iface, Ifaces);
- Collect_Implemented_Interfaces (Iface, Ifaces);
- end if;
+ -- Complete definition of first subtype
- Next_Elmt (Iface_Elmt);
- end loop;
- end if;
- end Collect_Implemented_Interfaces;
+ Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
+ Init_Size_Align (T);
+ Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+ Set_Small_Value (T, Small_Val);
+ Set_Delta_Value (T, Delta_Val);
+ Set_Is_Constrained (T);
+ end Ordinary_Fixed_Point_Type_Declaration;
- -- Start of processing for Process_Full_View
+ ----------------------------------
+ -- Preanalyze_Assert_Expression --
+ ----------------------------------
+ procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is
begin
- -- First some sanity checks that must be done after semantic
- -- decoration of the full view and thus cannot be placed with other
- -- similar checks in Find_Type_Name
+ In_Assertion_Expr := In_Assertion_Expr + 1;
+ Preanalyze_Spec_Expression (N, T);
+ In_Assertion_Expr := In_Assertion_Expr - 1;
+ end Preanalyze_Assert_Expression;
- if not Is_Limited_Type (Priv_T)
- and then (Is_Limited_Type (Full_T)
- or else Is_Limited_Composite (Full_T))
- then
- if In_Instance then
- null;
- else
- Error_Msg_N
- ("completion of nonlimited type cannot be limited", Full_T);
- Explain_Limited_Type (Full_T, Full_T);
- end if;
+ -----------------------------------
+ -- Preanalyze_Default_Expression --
+ -----------------------------------
- elsif Is_Abstract_Type (Full_T)
- and then not Is_Abstract_Type (Priv_T)
- then
- Error_Msg_N
- ("completion of nonabstract type cannot be abstract", Full_T);
+ procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is
+ Save_In_Default_Expr : constant Boolean := In_Default_Expr;
+ begin
+ In_Default_Expr := True;
+ Preanalyze_Spec_Expression (N, T);
+ In_Default_Expr := Save_In_Default_Expr;
+ end Preanalyze_Default_Expression;
- elsif Is_Tagged_Type (Priv_T)
- and then Is_Limited_Type (Priv_T)
- and then not Is_Limited_Type (Full_T)
- then
- -- If pragma CPP_Class was applied to the private declaration
- -- propagate the limitedness to the full-view
+ --------------------------------
+ -- Preanalyze_Spec_Expression --
+ --------------------------------
- if Is_CPP_Class (Priv_T) then
- Set_Is_Limited_Record (Full_T);
+ procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is
+ Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
+ begin
+ In_Spec_Expression := True;
+ Preanalyze_And_Resolve (N, T);
+ In_Spec_Expression := Save_In_Spec_Expression;
+ end Preanalyze_Spec_Expression;
- -- GNAT allow its own definition of Limited_Controlled to disobey
- -- this rule in order in ease the implementation. This test is safe
- -- because Root_Controlled is defined in a child of System that
- -- normal programs are not supposed to use.
+ ----------------------------------------
+ -- Prepare_Private_Subtype_Completion --
+ ----------------------------------------
- elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then
- Set_Is_Limited_Composite (Full_T);
- else
- Error_Msg_N
- ("completion of limited tagged type must be limited", Full_T);
+ procedure Prepare_Private_Subtype_Completion
+ (Id : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ Id_B : constant Entity_Id := Base_Type (Id);
+ Full_B : Entity_Id := Full_View (Id_B);
+ Full : Entity_Id;
+
+ begin
+ if Present (Full_B) then
+
+ -- Get to the underlying full view if necessary
+
+ if Is_Private_Type (Full_B)
+ and then Present (Underlying_Full_View (Full_B))
+ then
+ Full_B := Underlying_Full_View (Full_B);
end if;
- elsif Is_Generic_Type (Priv_T) then
- Error_Msg_N ("generic type cannot have a completion", Full_T);
+ -- The Base_Type is already completed, we can complete the subtype
+ -- now. We have to create a new entity with the same name, Thus we
+ -- can't use Create_Itype.
+
+ Full := Make_Defining_Identifier (Sloc (Id), Chars (Id));
+ Set_Is_Itype (Full);
+ Set_Associated_Node_For_Itype (Full, Related_Nod);
+ Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);
end if;
- -- Check that ancestor interfaces of private and full views are
- -- consistent. We omit this check for synchronized types because
- -- they are performed on the corresponding record type when frozen.
+ -- The parent subtype may be private, but the base might not, in some
+ -- nested instances. In that case, the subtype does not need to be
+ -- exchanged. It would still be nice to make private subtypes and their
+ -- bases consistent at all times ???
- if Ada_Version >= Ada_2005
- and then Is_Tagged_Type (Priv_T)
- and then Is_Tagged_Type (Full_T)
- and then not Is_Concurrent_Type (Full_T)
- then
- declare
- Iface : Entity_Id;
- Priv_T_Ifaces : constant Elist_Id := New_Elmt_List;
- Full_T_Ifaces : constant Elist_Id := New_Elmt_List;
+ if Is_Private_Type (Id_B) then
+ Append_Elmt (Id, Private_Dependents (Id_B));
+ end if;
+ end Prepare_Private_Subtype_Completion;
- begin
- Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
- Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
+ ---------------------------
+ -- Process_Discriminants --
+ ---------------------------
- -- Ada 2005 (AI-251): The partial view shall be a descendant of
- -- an interface type if and only if the full type is descendant
- -- of the interface type (AARM 7.3 (7.3/2)).
+ procedure Process_Discriminants
+ (N : Node_Id;
+ Prev : Entity_Id := Empty)
+ is
+ Elist : constant Elist_Id := New_Elmt_List;
+ Id : Node_Id;
+ Discr : Node_Id;
+ Discr_Number : Uint;
+ Discr_Type : Entity_Id;
+ Default_Present : Boolean := False;
+ Default_Not_Present : Boolean := False;
- Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
+ begin
+ -- A composite type other than an array type can have discriminants.
+ -- On entry, the current scope is the composite type.
- if Present (Iface) then
- Error_Msg_NE
- ("interface in partial view& not implemented by full type "
- & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
- end if;
+ -- The discriminants are initially entered into the scope of the type
+ -- via Enter_Name with the default Ekind of E_Void to prevent premature
+ -- use, as explained at the end of this procedure.
- Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
+ Discr := First (Discriminant_Specifications (N));
+ while Present (Discr) loop
+ Enter_Name (Defining_Identifier (Discr));
- if Present (Iface) then
- Error_Msg_NE
- ("interface & not implemented by partial view "
- & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
- end if;
- end;
- end if;
+ -- For navigation purposes we add a reference to the discriminant
+ -- in the entity for the type. If the current declaration is a
+ -- completion, place references on the partial view. Otherwise the
+ -- type is the current scope.
- if Is_Tagged_Type (Priv_T)
- and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
- and then Is_Derived_Type (Full_T)
- then
- Priv_Parent := Etype (Priv_T);
+ if Present (Prev) then
- -- The full view of a private extension may have been transformed
- -- into an unconstrained derived type declaration and a subtype
- -- declaration (see build_derived_record_type for details).
+ -- The references go on the partial view, if present. If the
+ -- partial view has discriminants, the references have been
+ -- generated already.
- if Nkind (N) = N_Subtype_Declaration then
- Full_Indic := Subtype_Indication (N);
- Full_Parent := Etype (Base_Type (Full_T));
+ if not Has_Discriminants (Prev) then
+ Generate_Reference (Prev, Defining_Identifier (Discr), 'd');
+ end if;
else
- Full_Indic := Subtype_Indication (Type_Definition (N));
- Full_Parent := Etype (Full_T);
+ Generate_Reference
+ (Current_Scope, Defining_Identifier (Discr), 'd');
end if;
- -- Check that the parent type of the full type is a descendant of
- -- the ancestor subtype given in the private extension. If either
- -- entity has an Etype equal to Any_Type then we had some previous
- -- error situation [7.3(8)].
+ if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
+ Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
- if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
- return;
+ -- Ada 2005 (AI-254)
- -- Ada 2005 (AI-251): Interfaces in the full type can be given in
- -- any order. Therefore we don't have to check that its parent must
- -- be a descendant of the parent of the private type declaration.
+ if Present (Access_To_Subprogram_Definition
+ (Discriminant_Type (Discr)))
+ and then Protected_Present (Access_To_Subprogram_Definition
+ (Discriminant_Type (Discr)))
+ then
+ Discr_Type :=
+ Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
+ end if;
- elsif Is_Interface (Priv_Parent)
- and then Is_Interface (Full_Parent)
- then
- null;
+ else
+ Find_Type (Discriminant_Type (Discr));
+ Discr_Type := Etype (Discriminant_Type (Discr));
- -- Ada 2005 (AI-251): If the parent of the private type declaration
- -- is an interface there is no need to check that it is an ancestor
- -- of the associated full type declaration. The required tests for
- -- this case are performed by Build_Derived_Record_Type.
+ if Error_Posted (Discriminant_Type (Discr)) then
+ Discr_Type := Any_Type;
+ end if;
+ end if;
- elsif not Is_Interface (Base_Type (Priv_Parent))
- and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
- then
- Error_Msg_N
- ("parent of full type must descend from parent"
- & " of private extension", Full_Indic);
+ -- Handling of discriminants that are access types
- -- First check a formal restriction, and then proceed with checking
- -- Ada rules. Since the formal restriction is not a serious error, we
- -- don't prevent further error detection for this check, hence the
- -- ELSE.
+ if Is_Access_Type (Discr_Type) then
- else
+ -- Ada 2005 (AI-230): Access discriminant allowed in non-
+ -- limited record types
- -- In formal mode, when completing a private extension the type
- -- named in the private part must be exactly the same as that
- -- named in the visible part.
+ if Ada_Version < Ada_2005 then
+ Check_Access_Discriminant_Requires_Limited
+ (Discr, Discriminant_Type (Discr));
+ end if;
- if Priv_Parent /= Full_Parent then
- Error_Msg_Name_1 := Chars (Priv_Parent);
- Check_SPARK_05_Restriction ("% expected", Full_Indic);
+ if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then
+ Error_Msg_N
+ ("(Ada 83) access discriminant not allowed", Discr);
end if;
- -- Check the rules of 7.3(10): if the private extension inherits
- -- known discriminants, then the full type must also inherit those
- -- discriminants from the same (ancestor) type, and the parent
- -- subtype of the full type must be constrained if and only if
- -- the ancestor subtype of the private extension is constrained.
+ -- If not access type, must be a discrete type
- if No (Discriminant_Specifications (Parent (Priv_T)))
- and then not Has_Unknown_Discriminants (Priv_T)
- and then Has_Discriminants (Base_Type (Priv_Parent))
- then
- declare
- Priv_Indic : constant Node_Id :=
- Subtype_Indication (Parent (Priv_T));
+ elsif not Is_Discrete_Type (Discr_Type) then
+ Error_Msg_N
+ ("discriminants must have a discrete or access type",
+ Discriminant_Type (Discr));
+ end if;
- Priv_Constr : constant Boolean :=
- Is_Constrained (Priv_Parent)
- or else
- Nkind (Priv_Indic) = N_Subtype_Indication
- or else
- Is_Constrained (Entity (Priv_Indic));
+ Set_Etype (Defining_Identifier (Discr), Discr_Type);
- Full_Constr : constant Boolean :=
- Is_Constrained (Full_Parent)
- or else
- Nkind (Full_Indic) = N_Subtype_Indication
- or else
- Is_Constrained (Entity (Full_Indic));
+ -- If a discriminant specification includes the assignment compound
+ -- delimiter followed by an expression, the expression is the default
+ -- expression of the discriminant; the default expression must be of
+ -- the type of the discriminant. (RM 3.7.1) Since this expression is
+ -- a default expression, we do the special preanalysis, since this
+ -- expression does not freeze (see section "Handling of Default and
+ -- Per-Object Expressions" in spec of package Sem).
- Priv_Discr : Entity_Id;
- Full_Discr : Entity_Id;
+ if Present (Expression (Discr)) then
+ Preanalyze_Spec_Expression (Expression (Discr), Discr_Type);
- begin
- Priv_Discr := First_Discriminant (Priv_Parent);
- Full_Discr := First_Discriminant (Full_Parent);
- while Present (Priv_Discr) and then Present (Full_Discr) loop
- if Original_Record_Component (Priv_Discr) =
- Original_Record_Component (Full_Discr)
- or else
- Corresponding_Discriminant (Priv_Discr) =
- Corresponding_Discriminant (Full_Discr)
- then
- null;
- else
- exit;
- end if;
+ -- Legaity checks
- Next_Discriminant (Priv_Discr);
- Next_Discriminant (Full_Discr);
- end loop;
+ if Nkind (N) = N_Formal_Type_Declaration then
+ Error_Msg_N
+ ("discriminant defaults not allowed for formal type",
+ Expression (Discr));
- if Present (Priv_Discr) or else Present (Full_Discr) then
- Error_Msg_N
- ("full view must inherit discriminants of the parent"
- & " type used in the private extension", Full_Indic);
+ -- Flag an error for a tagged type with defaulted discriminants,
+ -- excluding limited tagged types when compiling for Ada 2012
+ -- (see AI05-0214).
- elsif Priv_Constr and then not Full_Constr then
- Error_Msg_N
- ("parent subtype of full type must be constrained",
- Full_Indic);
+ elsif Is_Tagged_Type (Current_Scope)
+ and then (not Is_Limited_Type (Current_Scope)
+ or else Ada_Version < Ada_2012)
+ and then Comes_From_Source (N)
+ then
+ -- Note: see similar test in Check_Or_Process_Discriminants, to
+ -- handle the (illegal) case of the completion of an untagged
+ -- view with discriminants with defaults by a tagged full view.
+ -- We skip the check if Discr does not come from source, to
+ -- account for the case of an untagged derived type providing
+ -- defaults for a renamed discriminant from a private untagged
+ -- ancestor with a tagged full view (ACATS B460006).
- elsif Full_Constr and then not Priv_Constr then
- Error_Msg_N
- ("parent subtype of full type must be unconstrained",
- Full_Indic);
- end if;
- end;
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_N
+ ("discriminants of nonlimited tagged type cannot have"
+ & " defaults",
+ Expression (Discr));
+ else
+ Error_Msg_N
+ ("discriminants of tagged type cannot have defaults",
+ Expression (Discr));
+ end if;
- -- Check the rules of 7.3(12): if a partial view has neither
- -- known or unknown discriminants, then the full type
- -- declaration shall define a definite subtype.
+ else
+ Default_Present := True;
+ Append_Elmt (Expression (Discr), Elist);
- elsif not Has_Unknown_Discriminants (Priv_T)
- and then not Has_Discriminants (Priv_T)
- and then not Is_Constrained (Full_T)
+ -- Tag the defining identifiers for the discriminants with
+ -- their corresponding default expressions from the tree.
+
+ Set_Discriminant_Default_Value
+ (Defining_Identifier (Discr), Expression (Discr));
+ end if;
+
+ -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag
+ -- gets set unless we can be sure that no range check is required.
+
+ if (GNATprove_Mode or not Expander_Active)
+ and then not
+ Is_In_Range
+ (Expression (Discr), Discr_Type, Assume_Valid => True)
then
- Error_Msg_N
- ("full view must define a constrained type if partial view"
- & " has no discriminants", Full_T);
+ Set_Do_Range_Check (Expression (Discr));
end if;
- -- ??????? Do we implement the following properly ?????
- -- If the ancestor subtype of a private extension has constrained
- -- discriminants, then the parent subtype of the full view shall
- -- impose a statically matching constraint on those discriminants
- -- [7.3(13)].
+ -- No default discriminant value given
+
+ else
+ Default_Not_Present := True;
end if;
- else
- -- For untagged types, verify that a type without discriminants is
- -- not completed with an unconstrained type. A separate error message
- -- is produced if the full type has defaulted discriminants.
+ -- Ada 2005 (AI-231): Create an Itype that is a duplicate of
+ -- Discr_Type but with the null-exclusion attribute
- if not Is_Indefinite_Subtype (Priv_T)
- and then Is_Indefinite_Subtype (Full_T)
- then
- Error_Msg_Sloc := Sloc (Parent (Priv_T));
- Error_Msg_NE
- ("full view of& not compatible with declaration#",
- Full_T, Priv_T);
+ if Ada_Version >= Ada_2005 then
- if not Is_Tagged_Type (Full_T) then
- Error_Msg_N
- ("\one is constrained, the other unconstrained", Full_T);
- end if;
- end if;
- end if;
+ -- Ada 2005 (AI-231): Static checks
- -- AI-419: verify that the use of "limited" is consistent
+ if Can_Never_Be_Null (Discr_Type) then
+ Null_Exclusion_Static_Checks (Discr);
- declare
- Orig_Decl : constant Node_Id := Original_Node (N);
+ elsif Is_Access_Type (Discr_Type)
+ and then Null_Exclusion_Present (Discr)
- begin
- if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
- and then not Limited_Present (Parent (Priv_T))
- and then not Synchronized_Present (Parent (Priv_T))
- and then Nkind (Orig_Decl) = N_Full_Type_Declaration
- and then Nkind
- (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition
- and then Limited_Present (Type_Definition (Orig_Decl))
- then
- Error_Msg_N
- ("full view of non-limited extension cannot be limited", N);
- end if;
- end;
+ -- No need to check itypes because in their case this check
+ -- was done at their point of creation
- -- Ada 2005 (AI-443): A synchronized private extension must be
- -- completed by a task or protected type.
+ and then not Is_Itype (Discr_Type)
+ then
+ if Can_Never_Be_Null (Discr_Type) then
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ Discr,
+ Discr_Type);
+ end if;
- if Ada_Version >= Ada_2005
- and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
- and then Synchronized_Present (Parent (Priv_T))
- and then not Is_Concurrent_Type (Full_T)
- then
- Error_Msg_N ("full view of synchronized extension must " &
- "be synchronized type", N);
- end if;
+ Set_Etype (Defining_Identifier (Discr),
+ Create_Null_Excluding_Itype
+ (T => Discr_Type,
+ Related_Nod => Discr));
- -- Ada 2005 AI-363: if the full view has discriminants with
- -- defaults, it is illegal to declare constrained access subtypes
- -- whose designated type is the current type. This allows objects
- -- of the type that are declared in the heap to be unconstrained.
+ -- Check for improper null exclusion if the type is otherwise
+ -- legal for a discriminant.
- if not Has_Unknown_Discriminants (Priv_T)
- and then not Has_Discriminants (Priv_T)
- and then Has_Discriminants (Full_T)
- and then
- Present (Discriminant_Default_Value (First_Discriminant (Full_T)))
- then
- Set_Has_Constrained_Partial_View (Full_T);
- Set_Has_Constrained_Partial_View (Priv_T);
- end if;
+ elsif Null_Exclusion_Present (Discr)
+ and then Is_Discrete_Type (Discr_Type)
+ then
+ Error_Msg_N
+ ("null exclusion can only apply to an access type", Discr);
+ end if;
- -- Create a full declaration for all its subtypes recorded in
- -- Private_Dependents and swap them similarly to the base type. These
- -- are subtypes that have been define before the full declaration of
- -- the private type. We also swap the entry in Private_Dependents list
- -- so we can properly restore the private view on exit from the scope.
+ -- Ada 2005 (AI-402): access discriminants of nonlimited types
+ -- can't have defaults. Synchronized types, or types that are
+ -- explicitly limited are fine, but special tests apply to derived
+ -- types in generics: in a generic body we have to assume the
+ -- worst, and therefore defaults are not allowed if the parent is
+ -- a generic formal private type (see ACATS B370001).
- declare
- Priv_Elmt : Elmt_Id;
- Priv_Scop : Entity_Id;
- Priv : Entity_Id;
- Full : Entity_Id;
+ if Is_Access_Type (Discr_Type) and then Default_Present then
+ if Ekind (Discr_Type) /= E_Anonymous_Access_Type
+ or else Is_Limited_Record (Current_Scope)
+ or else Is_Concurrent_Type (Current_Scope)
+ or else Is_Concurrent_Record_Type (Current_Scope)
+ or else Ekind (Current_Scope) = E_Limited_Private_Type
+ then
+ if not Is_Derived_Type (Current_Scope)
+ or else not Is_Generic_Type (Etype (Current_Scope))
+ or else not In_Package_Body (Scope (Etype (Current_Scope)))
+ or else Limited_Present
+ (Type_Definition (Parent (Current_Scope)))
+ then
+ null;
- begin
- Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
- while Present (Priv_Elmt) loop
- Priv := Node (Priv_Elmt);
- Priv_Scop := Scope (Priv);
+ else
+ Error_Msg_N ("access discriminants of nonlimited types",
+ Expression (Discr));
+ Error_Msg_N ("\cannot have defaults", Expression (Discr));
+ end if;
- if Ekind_In (Priv, E_Private_Subtype,
- E_Limited_Private_Subtype,
- E_Record_Subtype_With_Private)
- then
- Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
- Set_Is_Itype (Full);
- Set_Parent (Full, Parent (Priv));
- Set_Associated_Node_For_Itype (Full, N);
+ elsif Present (Expression (Discr)) then
+ Error_Msg_N
+ ("(Ada 2005) access discriminants of nonlimited types",
+ Expression (Discr));
+ Error_Msg_N ("\cannot have defaults", Expression (Discr));
+ end if;
+ end if;
+ end if;
- -- Now we need to complete the private subtype, but since the
- -- base type has already been swapped, we must also swap the
- -- subtypes (and thus, reverse the arguments in the call to
- -- Complete_Private_Subtype). Also note that we may need to
- -- re-establish the scope of the private subtype.
+ -- A discriminant cannot be effectively volatile. This check is only
+ -- relevant when SPARK_Mode is on as it is not standard Ada legality
+ -- rule (SPARK RM 7.1.3(6)).
- Copy_And_Swap (Priv, Full);
+ if SPARK_Mode = On
+ and then Is_Effectively_Volatile (Defining_Identifier (Discr))
+ then
+ Error_Msg_N ("discriminant cannot be volatile", Discr);
+ end if;
- if not In_Open_Scopes (Priv_Scop) then
- Push_Scope (Priv_Scop);
+ Next (Discr);
+ end loop;
- else
- -- Reset Priv_Scop to Empty to indicate no scope was pushed
+ -- An element list consisting of the default expressions of the
+ -- discriminants is constructed in the above loop and used to set
+ -- the Discriminant_Constraint attribute for the type. If an object
+ -- is declared of this (record or task) type without any explicit
+ -- discriminant constraint given, this element list will form the
+ -- actual parameters for the corresponding initialization procedure
+ -- for the type.
- Priv_Scop := Empty;
- end if;
+ Set_Discriminant_Constraint (Current_Scope, Elist);
+ Set_Stored_Constraint (Current_Scope, No_Elist);
- Complete_Private_Subtype (Full, Priv, Full_T, N);
+ -- Default expressions must be provided either for all or for none
+ -- of the discriminants of a discriminant part. (RM 3.7.1)
- if Present (Priv_Scop) then
- Pop_Scope;
- end if;
+ if Default_Present and then Default_Not_Present then
+ Error_Msg_N
+ ("incomplete specification of defaults for discriminants", N);
+ end if;
- Replace_Elmt (Priv_Elmt, Full);
- end if;
+ -- The use of the name of a discriminant is not allowed in default
+ -- expressions of a discriminant part if the specification of the
+ -- discriminant is itself given in the discriminant part. (RM 3.7.1)
- Next_Elmt (Priv_Elmt);
- end loop;
- end;
+ -- To detect this, the discriminant names are entered initially with an
+ -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any
+ -- attempt to use a void entity (for example in an expression that is
+ -- type-checked) produces the error message: premature usage. Now after
+ -- completing the semantic analysis of the discriminant part, we can set
+ -- the Ekind of all the discriminants appropriately.
- -- If the private view was tagged, copy the new primitive operations
- -- from the private view to the full view.
+ Discr := First (Discriminant_Specifications (N));
+ Discr_Number := Uint_1;
+ while Present (Discr) loop
+ Id := Defining_Identifier (Discr);
+ Set_Ekind (Id, E_Discriminant);
+ Init_Component_Location (Id);
+ Init_Esize (Id);
+ Set_Discriminant_Number (Id, Discr_Number);
- if Is_Tagged_Type (Full_T) then
- declare
- Disp_Typ : Entity_Id;
- Full_List : Elist_Id;
- Prim : Entity_Id;
- Prim_Elmt : Elmt_Id;
- Priv_List : Elist_Id;
+ -- Make sure this is always set, even in illegal programs
- function Contains
- (E : Entity_Id;
- L : Elist_Id) return Boolean;
- -- Determine whether list L contains element E
+ Set_Corresponding_Discriminant (Id, Empty);
- --------------
- -- Contains --
- --------------
+ -- Initialize the Original_Record_Component to the entity itself.
+ -- Inherit_Components will propagate the right value to
+ -- discriminants in derived record types.
- function Contains
- (E : Entity_Id;
- L : Elist_Id) return Boolean
- is
- List_Elmt : Elmt_Id;
+ Set_Original_Record_Component (Id, Id);
- begin
- List_Elmt := First_Elmt (L);
- while Present (List_Elmt) loop
- if Node (List_Elmt) = E then
- return True;
- end if;
+ -- Create the discriminal for the discriminant
- Next_Elmt (List_Elmt);
- end loop;
+ Build_Discriminal (Id);
- return False;
- end Contains;
+ Next (Discr);
+ Discr_Number := Discr_Number + 1;
+ end loop;
- -- Start of processing
+ Set_Has_Discriminants (Current_Scope);
+ end Process_Discriminants;
- begin
- if Is_Tagged_Type (Priv_T) then
- Priv_List := Primitive_Operations (Priv_T);
- Prim_Elmt := First_Elmt (Priv_List);
+ -----------------------
+ -- Process_Full_View --
+ -----------------------
- -- In the case of a concurrent type completing a private tagged
- -- type, primitives may have been declared in between the two
- -- views. These subprograms need to be wrapped the same way
- -- entries and protected procedures are handled because they
- -- cannot be directly shared by the two views.
+ procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
+ procedure Collect_Implemented_Interfaces
+ (Typ : Entity_Id;
+ Ifaces : Elist_Id);
+ -- Ada 2005: Gather all the interfaces that Typ directly or
+ -- inherently implements. Duplicate entries are not added to
+ -- the list Ifaces.
- if Is_Concurrent_Type (Full_T) then
- declare
- Conc_Typ : constant Entity_Id :=
- Corresponding_Record_Type (Full_T);
- Curr_Nod : Node_Id := Parent (Conc_Typ);
- Wrap_Spec : Node_Id;
+ ------------------------------------
+ -- Collect_Implemented_Interfaces --
+ ------------------------------------
- begin
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ procedure Collect_Implemented_Interfaces
+ (Typ : Entity_Id;
+ Ifaces : Elist_Id)
+ is
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
- if Comes_From_Source (Prim)
- and then not Is_Abstract_Subprogram (Prim)
- then
- Wrap_Spec :=
- Make_Subprogram_Declaration (Sloc (Prim),
- Specification =>
- Build_Wrapper_Spec
- (Subp_Id => Prim,
- Obj_Typ => Conc_Typ,
- Formals =>
- Parameter_Specifications (
- Parent (Prim))));
+ begin
+ -- Abstract interfaces are only associated with tagged record types
- Insert_After (Curr_Nod, Wrap_Spec);
- Curr_Nod := Wrap_Spec;
+ if not Is_Tagged_Type (Typ)
+ or else not Is_Record_Type (Typ)
+ then
+ return;
+ end if;
- Analyze (Wrap_Spec);
- end if;
+ -- Recursively climb to the ancestors
- Next_Elmt (Prim_Elmt);
- end loop;
+ if Etype (Typ) /= Typ
- return;
- end;
+ -- Protect the frontend against wrong cyclic declarations like:
- -- For non-concurrent types, transfer explicit primitives, but
- -- omit those inherited from the parent of the private view
- -- since they will be re-inherited later on.
+ -- type B is new A with private;
+ -- type C is new A with private;
+ -- private
+ -- type B is new C with null record;
+ -- type C is new B with null record;
- else
- Full_List := Primitive_Operations (Full_T);
+ and then Etype (Typ) /= Priv_T
+ and then Etype (Typ) /= Full_T
+ then
+ -- Keep separate the management of private type declarations
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ if Ekind (Typ) = E_Record_Type_With_Private then
- if Comes_From_Source (Prim)
- and then not Contains (Prim, Full_List)
- then
- Append_Elmt (Prim, Full_List);
- end if;
+ -- Handle the following illegal usage:
+ -- type Private_Type is tagged private;
+ -- private
+ -- type Private_Type is new Type_Implementing_Iface;
- Next_Elmt (Prim_Elmt);
- end loop;
+ if Present (Full_View (Typ))
+ and then Etype (Typ) /= Full_View (Typ)
+ then
+ if Is_Interface (Etype (Typ)) then
+ Append_Unique_Elmt (Etype (Typ), Ifaces);
+ end if;
+
+ Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
end if;
- -- Untagged private view
+ -- Non-private types
else
- Full_List := Primitive_Operations (Full_T);
+ if Is_Interface (Etype (Typ)) then
+ Append_Unique_Elmt (Etype (Typ), Ifaces);
+ end if;
- -- In this case the partial view is untagged, so here we locate
- -- all of the earlier primitives that need to be treated as
- -- dispatching (those that appear between the two views). Note
- -- that these additional operations must all be new operations
- -- (any earlier operations that override inherited operations
- -- of the full view will already have been inserted in the
- -- primitives list, marked by Check_Operation_From_Private_View
- -- as dispatching. Note that implicit "/=" operators are
- -- excluded from being added to the primitives list since they
- -- shouldn't be treated as dispatching (tagged "/=" is handled
- -- specially).
+ Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
+ end if;
+ end if;
- Prim := Next_Entity (Full_T);
- while Present (Prim) and then Prim /= Priv_T loop
- if Ekind_In (Prim, E_Procedure, E_Function) then
- Disp_Typ := Find_Dispatching_Type (Prim);
+ -- Handle entities in the list of abstract interfaces
- if Disp_Typ = Full_T
- and then (Chars (Prim) /= Name_Op_Ne
- or else Comes_From_Source (Prim))
- then
- Check_Controlling_Formals (Full_T, Prim);
+ if Present (Interfaces (Typ)) then
+ Iface_Elmt := First_Elmt (Interfaces (Typ));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
- if not Is_Dispatching_Operation (Prim) then
- Append_Elmt (Prim, Full_List);
- Set_Is_Dispatching_Operation (Prim, True);
- Set_DT_Position (Prim, No_Uint);
- end if;
+ pragma Assert (Is_Interface (Iface));
- elsif Is_Dispatching_Operation (Prim)
- and then Disp_Typ /= Full_T
- then
+ if not Contain_Interface (Iface, Ifaces) then
+ Append_Elmt (Iface, Ifaces);
+ Collect_Implemented_Interfaces (Iface, Ifaces);
+ end if;
- -- Verify that it is not otherwise controlled by a
- -- formal or a return value of type T.
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+ end Collect_Implemented_Interfaces;
- Check_Controlling_Formals (Disp_Typ, Prim);
- end if;
- end if;
+ -- Local variables
- Next_Entity (Prim);
- end loop;
- end if;
+ Full_Indic : Node_Id;
+ Full_Parent : Entity_Id;
+ Priv_Parent : Entity_Id;
- -- For the tagged case, the two views can share the same primitive
- -- operations list and the same class-wide type. Update attributes
- -- of the class-wide type which depend on the full declaration.
+ -- Start of processing for Process_Full_View
- if Is_Tagged_Type (Priv_T) then
- Set_Direct_Primitive_Operations (Priv_T, Full_List);
- Set_Class_Wide_Type
- (Base_Type (Full_T), Class_Wide_Type (Priv_T));
+ begin
+ -- First some sanity checks that must be done after semantic
+ -- decoration of the full view and thus cannot be placed with other
+ -- similar checks in Find_Type_Name
- Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
- Set_Has_Protected
- (Class_Wide_Type (Priv_T), Has_Protected (Full_T));
- end if;
- end;
- end if;
+ if not Is_Limited_Type (Priv_T)
+ and then (Is_Limited_Type (Full_T)
+ or else Is_Limited_Composite (Full_T))
+ then
+ if In_Instance then
+ null;
+ else
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", Full_T);
+ Explain_Limited_Type (Full_T, Full_T);
+ end if;
- -- Ada 2005 AI 161: Check preelaborable initialization consistency
+ elsif Is_Abstract_Type (Full_T)
+ and then not Is_Abstract_Type (Priv_T)
+ then
+ Error_Msg_N
+ ("completion of nonabstract type cannot be abstract", Full_T);
- if Known_To_Have_Preelab_Init (Priv_T) then
+ elsif Is_Tagged_Type (Priv_T)
+ and then Is_Limited_Type (Priv_T)
+ and then not Is_Limited_Type (Full_T)
+ then
+ -- If pragma CPP_Class was applied to the private declaration
+ -- propagate the limitedness to the full-view
- -- Case where there is a pragma Preelaborable_Initialization. We
- -- always allow this in predefined units, which is cheating a bit,
- -- but it means we don't have to struggle to meet the requirements in
- -- the RM for having Preelaborable Initialization. Otherwise we
- -- require that the type meets the RM rules. But we can't check that
- -- yet, because of the rule about overriding Initialize, so we simply
- -- set a flag that will be checked at freeze time.
+ if Is_CPP_Class (Priv_T) then
+ Set_Is_Limited_Record (Full_T);
- if not In_Predefined_Unit (Full_T) then
- Set_Must_Have_Preelab_Init (Full_T);
+ -- GNAT allow its own definition of Limited_Controlled to disobey
+ -- this rule in order in ease the implementation. This test is safe
+ -- because Root_Controlled is defined in a child of System that
+ -- normal programs are not supposed to use.
+
+ elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then
+ Set_Is_Limited_Composite (Full_T);
+ else
+ Error_Msg_N
+ ("completion of limited tagged type must be limited", Full_T);
end if;
+
+ elsif Is_Generic_Type (Priv_T) then
+ Error_Msg_N ("generic type cannot have a completion", Full_T);
end if;
- -- If pragma CPP_Class was applied to the private type declaration,
- -- propagate it now to the full type declaration.
+ -- Check that ancestor interfaces of private and full views are
+ -- consistent. We omit this check for synchronized types because
+ -- they are performed on the corresponding record type when frozen.
- if Is_CPP_Class (Priv_T) then
- Set_Is_CPP_Class (Full_T);
- Set_Convention (Full_T, Convention_CPP);
+ if Ada_Version >= Ada_2005
+ and then Is_Tagged_Type (Priv_T)
+ and then Is_Tagged_Type (Full_T)
+ and then not Is_Concurrent_Type (Full_T)
+ then
+ declare
+ Iface : Entity_Id;
+ Priv_T_Ifaces : constant Elist_Id := New_Elmt_List;
+ Full_T_Ifaces : constant Elist_Id := New_Elmt_List;
- -- Check that components of imported CPP types do not have default
- -- expressions.
+ begin
+ Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
+ Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
- Check_CPP_Type_Has_No_Defaults (Full_T);
- end if;
+ -- Ada 2005 (AI-251): The partial view shall be a descendant of
+ -- an interface type if and only if the full type is descendant
+ -- of the interface type (AARM 7.3 (7.3/2)).
- -- If the private view has user specified stream attributes, then so has
- -- the full view.
+ Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
- -- Why the test, how could these flags be already set in Full_T ???
+ if Present (Iface) then
+ Error_Msg_NE
+ ("interface in partial view& not implemented by full type "
+ & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
+ end if;
- if Has_Specified_Stream_Read (Priv_T) then
- Set_Has_Specified_Stream_Read (Full_T);
- end if;
+ Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
- if Has_Specified_Stream_Write (Priv_T) then
- Set_Has_Specified_Stream_Write (Full_T);
+ if Present (Iface) then
+ Error_Msg_NE
+ ("interface & not implemented by partial view "
+ & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
+ end if;
+ end;
end if;
- if Has_Specified_Stream_Input (Priv_T) then
- Set_Has_Specified_Stream_Input (Full_T);
- end if;
+ if Is_Tagged_Type (Priv_T)
+ and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
+ and then Is_Derived_Type (Full_T)
+ then
+ Priv_Parent := Etype (Priv_T);
- if Has_Specified_Stream_Output (Priv_T) then
- Set_Has_Specified_Stream_Output (Full_T);
- end if;
+ -- The full view of a private extension may have been transformed
+ -- into an unconstrained derived type declaration and a subtype
+ -- declaration (see build_derived_record_type for details).
- -- Propagate the attributes related to pragma Default_Initial_Condition
- -- from the private to the full view. Note that both flags are mutually
- -- exclusive.
+ if Nkind (N) = N_Subtype_Declaration then
+ Full_Indic := Subtype_Indication (N);
+ Full_Parent := Etype (Base_Type (Full_T));
+ else
+ Full_Indic := Subtype_Indication (Type_Definition (N));
+ Full_Parent := Etype (Full_T);
+ end if;
- if Has_Inherited_Default_Init_Cond (Priv_T) then
- Set_Has_Inherited_Default_Init_Cond (Full_T);
- Set_Default_Init_Cond_Procedure
- (Full_T, Default_Init_Cond_Procedure (Priv_T));
+ -- Check that the parent type of the full type is a descendant of
+ -- the ancestor subtype given in the private extension. If either
+ -- entity has an Etype equal to Any_Type then we had some previous
+ -- error situation [7.3(8)].
- elsif Has_Default_Init_Cond (Priv_T) then
- Set_Has_Default_Init_Cond (Full_T);
- Set_Default_Init_Cond_Procedure
- (Full_T, Default_Init_Cond_Procedure (Priv_T));
- end if;
+ if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
+ return;
- -- Propagate invariants to full type
+ -- Ada 2005 (AI-251): Interfaces in the full type can be given in
+ -- any order. Therefore we don't have to check that its parent must
+ -- be a descendant of the parent of the private type declaration.
- if Has_Invariants (Priv_T) then
- Set_Has_Invariants (Full_T);
- Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T));
- end if;
+ elsif Is_Interface (Priv_Parent)
+ and then Is_Interface (Full_Parent)
+ then
+ null;
- if Has_Inheritable_Invariants (Priv_T) then
- Set_Has_Inheritable_Invariants (Full_T);
- end if;
+ -- Ada 2005 (AI-251): If the parent of the private type declaration
+ -- is an interface there is no need to check that it is an ancestor
+ -- of the associated full type declaration. The required tests for
+ -- this case are performed by Build_Derived_Record_Type.
- -- Propagate predicates to full type, and predicate function if already
- -- defined. It is not clear that this can actually happen? the partial
- -- view cannot be frozen yet, and the predicate function has not been
- -- built. Still it is a cheap check and seems safer to make it.
+ elsif not Is_Interface (Base_Type (Priv_Parent))
+ and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
+ then
+ Error_Msg_N
+ ("parent of full type must descend from parent"
+ & " of private extension", Full_Indic);
+
+ -- First check a formal restriction, and then proceed with checking
+ -- Ada rules. Since the formal restriction is not a serious error, we
+ -- don't prevent further error detection for this check, hence the
+ -- ELSE.
- if Has_Predicates (Priv_T) then
- if Present (Predicate_Function (Priv_T)) then
- Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
- end if;
+ else
- Set_Has_Predicates (Full_T);
- end if;
- end Process_Full_View;
+ -- In formal mode, when completing a private extension the type
+ -- named in the private part must be exactly the same as that
+ -- named in the visible part.
- -----------------------------------
- -- Process_Incomplete_Dependents --
- -----------------------------------
+ if Priv_Parent /= Full_Parent then
+ Error_Msg_Name_1 := Chars (Priv_Parent);
+ Check_SPARK_05_Restriction ("% expected", Full_Indic);
+ end if;
- procedure Process_Incomplete_Dependents
- (N : Node_Id;
- Full_T : Entity_Id;
- Inc_T : Entity_Id)
- is
- Inc_Elmt : Elmt_Id;
- Priv_Dep : Entity_Id;
- New_Subt : Entity_Id;
+ -- Check the rules of 7.3(10): if the private extension inherits
+ -- known discriminants, then the full type must also inherit those
+ -- discriminants from the same (ancestor) type, and the parent
+ -- subtype of the full type must be constrained if and only if
+ -- the ancestor subtype of the private extension is constrained.
- Disc_Constraint : Elist_Id;
+ if No (Discriminant_Specifications (Parent (Priv_T)))
+ and then not Has_Unknown_Discriminants (Priv_T)
+ and then Has_Discriminants (Base_Type (Priv_Parent))
+ then
+ declare
+ Priv_Indic : constant Node_Id :=
+ Subtype_Indication (Parent (Priv_T));
- begin
- if No (Private_Dependents (Inc_T)) then
- return;
- end if;
+ Priv_Constr : constant Boolean :=
+ Is_Constrained (Priv_Parent)
+ or else
+ Nkind (Priv_Indic) = N_Subtype_Indication
+ or else
+ Is_Constrained (Entity (Priv_Indic));
- -- Itypes that may be generated by the completion of an incomplete
- -- subtype are not used by the back-end and not attached to the tree.
- -- They are created only for constraint-checking purposes.
+ Full_Constr : constant Boolean :=
+ Is_Constrained (Full_Parent)
+ or else
+ Nkind (Full_Indic) = N_Subtype_Indication
+ or else
+ Is_Constrained (Entity (Full_Indic));
- Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
- while Present (Inc_Elmt) loop
- Priv_Dep := Node (Inc_Elmt);
+ Priv_Discr : Entity_Id;
+ Full_Discr : Entity_Id;
- if Ekind (Priv_Dep) = E_Subprogram_Type then
+ begin
+ Priv_Discr := First_Discriminant (Priv_Parent);
+ Full_Discr := First_Discriminant (Full_Parent);
+ while Present (Priv_Discr) and then Present (Full_Discr) loop
+ if Original_Record_Component (Priv_Discr) =
+ Original_Record_Component (Full_Discr)
+ or else
+ Corresponding_Discriminant (Priv_Discr) =
+ Corresponding_Discriminant (Full_Discr)
+ then
+ null;
+ else
+ exit;
+ end if;
- -- An Access_To_Subprogram type may have a return type or a
- -- parameter type that is incomplete. Replace with the full view.
+ Next_Discriminant (Priv_Discr);
+ Next_Discriminant (Full_Discr);
+ end loop;
- if Etype (Priv_Dep) = Inc_T then
- Set_Etype (Priv_Dep, Full_T);
- end if;
+ if Present (Priv_Discr) or else Present (Full_Discr) then
+ Error_Msg_N
+ ("full view must inherit discriminants of the parent"
+ & " type used in the private extension", Full_Indic);
- declare
- Formal : Entity_Id;
+ elsif Priv_Constr and then not Full_Constr then
+ Error_Msg_N
+ ("parent subtype of full type must be constrained",
+ Full_Indic);
- begin
- Formal := First_Formal (Priv_Dep);
- while Present (Formal) loop
- if Etype (Formal) = Inc_T then
- Set_Etype (Formal, Full_T);
+ elsif Full_Constr and then not Priv_Constr then
+ Error_Msg_N
+ ("parent subtype of full type must be unconstrained",
+ Full_Indic);
end if;
+ end;
- Next_Formal (Formal);
- end loop;
- end;
+ -- Check the rules of 7.3(12): if a partial view has neither
+ -- known or unknown discriminants, then the full type
+ -- declaration shall define a definite subtype.
- elsif Is_Overloadable (Priv_Dep) then
+ elsif not Has_Unknown_Discriminants (Priv_T)
+ and then not Has_Discriminants (Priv_T)
+ and then not Is_Constrained (Full_T)
+ then
+ Error_Msg_N
+ ("full view must define a constrained type if partial view"
+ & " has no discriminants", Full_T);
+ end if;
- -- If a subprogram in the incomplete dependents list is primitive
- -- for a tagged full type then mark it as a dispatching operation,
- -- check whether it overrides an inherited subprogram, and check
- -- restrictions on its controlling formals. Note that a protected
- -- operation is never dispatching: only its wrapper operation
- -- (which has convention Ada) is.
+ -- ??????? Do we implement the following properly ?????
+ -- If the ancestor subtype of a private extension has constrained
+ -- discriminants, then the parent subtype of the full view shall
+ -- impose a statically matching constraint on those discriminants
+ -- [7.3(13)].
+ end if;
- if Is_Tagged_Type (Full_T)
- and then Is_Primitive (Priv_Dep)
- and then Convention (Priv_Dep) /= Convention_Protected
- then
- Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
- Set_Is_Dispatching_Operation (Priv_Dep);
- Check_Controlling_Formals (Full_T, Priv_Dep);
+ else
+ -- For untagged types, verify that a type without discriminants is
+ -- not completed with an unconstrained type. A separate error message
+ -- is produced if the full type has defaulted discriminants.
+
+ if not Is_Indefinite_Subtype (Priv_T)
+ and then Is_Indefinite_Subtype (Full_T)
+ then
+ Error_Msg_Sloc := Sloc (Parent (Priv_T));
+ Error_Msg_NE
+ ("full view of& not compatible with declaration#",
+ Full_T, Priv_T);
+
+ if not Is_Tagged_Type (Full_T) then
+ Error_Msg_N
+ ("\one is constrained, the other unconstrained", Full_T);
end if;
+ end if;
+ end if;
- elsif Ekind (Priv_Dep) = E_Subprogram_Body then
+ -- AI-419: verify that the use of "limited" is consistent
- -- Can happen during processing of a body before the completion
- -- of a TA type. Ignore, because spec is also on dependent list.
+ declare
+ Orig_Decl : constant Node_Id := Original_Node (N);
- return;
+ begin
+ if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
+ and then not Limited_Present (Parent (Priv_T))
+ and then not Synchronized_Present (Parent (Priv_T))
+ and then Nkind (Orig_Decl) = N_Full_Type_Declaration
+ and then Nkind
+ (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition
+ and then Limited_Present (Type_Definition (Orig_Decl))
+ then
+ Error_Msg_N
+ ("full view of non-limited extension cannot be limited", N);
+ end if;
+ end;
- -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a
- -- corresponding subtype of the full view.
+ -- Ada 2005 (AI-443): A synchronized private extension must be
+ -- completed by a task or protected type.
- elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then
- Set_Subtype_Indication
- (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep)));
- Set_Etype (Priv_Dep, Full_T);
- Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
- Set_Analyzed (Parent (Priv_Dep), False);
+ if Ada_Version >= Ada_2005
+ and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
+ and then Synchronized_Present (Parent (Priv_T))
+ and then not Is_Concurrent_Type (Full_T)
+ then
+ Error_Msg_N ("full view of synchronized extension must " &
+ "be synchronized type", N);
+ end if;
- -- Reanalyze the declaration, suppressing the call to
- -- Enter_Name to avoid duplicate names.
+ -- Ada 2005 AI-363: if the full view has discriminants with
+ -- defaults, it is illegal to declare constrained access subtypes
+ -- whose designated type is the current type. This allows objects
+ -- of the type that are declared in the heap to be unconstrained.
- Analyze_Subtype_Declaration
- (N => Parent (Priv_Dep),
- Skip => True);
+ if not Has_Unknown_Discriminants (Priv_T)
+ and then not Has_Discriminants (Priv_T)
+ and then Has_Discriminants (Full_T)
+ and then
+ Present (Discriminant_Default_Value (First_Discriminant (Full_T)))
+ then
+ Set_Has_Constrained_Partial_View (Full_T);
+ Set_Has_Constrained_Partial_View (Priv_T);
+ end if;
- -- Dependent is a subtype
+ -- Create a full declaration for all its subtypes recorded in
+ -- Private_Dependents and swap them similarly to the base type. These
+ -- are subtypes that have been define before the full declaration of
+ -- the private type. We also swap the entry in Private_Dependents list
+ -- so we can properly restore the private view on exit from the scope.
- else
- -- We build a new subtype indication using the full view of the
- -- incomplete parent. The discriminant constraints have been
- -- elaborated already at the point of the subtype declaration.
+ declare
+ Priv_Elmt : Elmt_Id;
+ Priv_Scop : Entity_Id;
+ Priv : Entity_Id;
+ Full : Entity_Id;
- New_Subt := Create_Itype (E_Void, N);
+ begin
+ Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
+ while Present (Priv_Elmt) loop
+ Priv := Node (Priv_Elmt);
+ Priv_Scop := Scope (Priv);
- if Has_Discriminants (Full_T) then
- Disc_Constraint := Discriminant_Constraint (Priv_Dep);
- else
- Disc_Constraint := No_Elist;
- end if;
+ if Ekind_In (Priv, E_Private_Subtype,
+ E_Limited_Private_Subtype,
+ E_Record_Subtype_With_Private)
+ then
+ Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
+ Set_Is_Itype (Full);
+ Set_Parent (Full, Parent (Priv));
+ Set_Associated_Node_For_Itype (Full, N);
+
+ -- Now we need to complete the private subtype, but since the
+ -- base type has already been swapped, we must also swap the
+ -- subtypes (and thus, reverse the arguments in the call to
+ -- Complete_Private_Subtype). Also note that we may need to
+ -- re-establish the scope of the private subtype.
+
+ Copy_And_Swap (Priv, Full);
- Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
- Set_Full_View (Priv_Dep, New_Subt);
- end if;
+ if not In_Open_Scopes (Priv_Scop) then
+ Push_Scope (Priv_Scop);
- Next_Elmt (Inc_Elmt);
- end loop;
- end Process_Incomplete_Dependents;
+ else
+ -- Reset Priv_Scop to Empty to indicate no scope was pushed
- --------------------------------
- -- Process_Range_Expr_In_Decl --
- --------------------------------
+ Priv_Scop := Empty;
+ end if;
- procedure Process_Range_Expr_In_Decl
- (R : Node_Id;
- T : Entity_Id;
- Subtyp : Entity_Id := Empty;
- Check_List : List_Id := Empty_List;
- R_Check_Off : Boolean := False;
- In_Iter_Schm : Boolean := False)
- is
- Lo, Hi : Node_Id;
- R_Checks : Check_Result;
- Insert_Node : Node_Id;
- Def_Id : Entity_Id;
+ Complete_Private_Subtype (Full, Priv, Full_T, N);
- begin
- Analyze_And_Resolve (R, Base_Type (T));
+ if Present (Priv_Scop) then
+ Pop_Scope;
+ end if;
- if Nkind (R) = N_Range then
+ Replace_Elmt (Priv_Elmt, Full);
+ end if;
- -- In SPARK, all ranges should be static, with the exception of the
- -- discrete type definition of a loop parameter specification.
+ Next_Elmt (Priv_Elmt);
+ end loop;
+ end;
- if not In_Iter_Schm
- and then not Is_OK_Static_Range (R)
- then
- Check_SPARK_05_Restriction ("range should be static", R);
- end if;
+ -- If the private view was tagged, copy the new primitive operations
+ -- from the private view to the full view.
- Lo := Low_Bound (R);
- Hi := High_Bound (R);
+ if Is_Tagged_Type (Full_T) then
+ declare
+ Disp_Typ : Entity_Id;
+ Full_List : Elist_Id;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Priv_List : Elist_Id;
- -- We need to ensure validity of the bounds here, because if we
- -- go ahead and do the expansion, then the expanded code will get
- -- analyzed with range checks suppressed and we miss the check.
- -- Validity checks on the range of a quantified expression are
- -- delayed until the construct is transformed into a loop.
+ function Contains
+ (E : Entity_Id;
+ L : Elist_Id) return Boolean;
+ -- Determine whether list L contains element E
- if Nkind (Parent (R)) /= N_Loop_Parameter_Specification
- or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression
- then
- Validity_Check_Range (R);
- end if;
+ --------------
+ -- Contains --
+ --------------
- -- If there were errors in the declaration, try and patch up some
- -- common mistakes in the bounds. The cases handled are literals
- -- which are Integer where the expected type is Real and vice versa.
- -- These corrections allow the compilation process to proceed further
- -- along since some basic assumptions of the format of the bounds
- -- are guaranteed.
+ function Contains
+ (E : Entity_Id;
+ L : Elist_Id) return Boolean
+ is
+ List_Elmt : Elmt_Id;
- if Etype (R) = Any_Type then
- if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then
- Rewrite (Lo,
- Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo))));
+ begin
+ List_Elmt := First_Elmt (L);
+ while Present (List_Elmt) loop
+ if Node (List_Elmt) = E then
+ return True;
+ end if;
- elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
- Rewrite (Hi,
- Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
+ Next_Elmt (List_Elmt);
+ end loop;
- elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then
- Rewrite (Lo,
- Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo))));
+ return False;
+ end Contains;
- elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then
- Rewrite (Hi,
- Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi))));
- end if;
+ -- Start of processing
- Set_Etype (Lo, T);
- Set_Etype (Hi, T);
- end if;
+ begin
+ if Is_Tagged_Type (Priv_T) then
+ Priv_List := Primitive_Operations (Priv_T);
+ Prim_Elmt := First_Elmt (Priv_List);
- -- If the bounds of the range have been mistakenly given as string
- -- literals (perhaps in place of character literals), then an error
- -- has already been reported, but we rewrite the string literal as a
- -- bound of the range's type to avoid blowups in later processing
- -- that looks at static values.
+ -- In the case of a concurrent type completing a private tagged
+ -- type, primitives may have been declared in between the two
+ -- views. These subprograms need to be wrapped the same way
+ -- entries and protected procedures are handled because they
+ -- cannot be directly shared by the two views.
- if Nkind (Lo) = N_String_Literal then
- Rewrite (Lo,
- Make_Attribute_Reference (Sloc (Lo),
- Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (T, Sloc (Lo))));
- Analyze_And_Resolve (Lo);
- end if;
+ if Is_Concurrent_Type (Full_T) then
+ declare
+ Conc_Typ : constant Entity_Id :=
+ Corresponding_Record_Type (Full_T);
+ Curr_Nod : Node_Id := Parent (Conc_Typ);
+ Wrap_Spec : Node_Id;
- if Nkind (Hi) = N_String_Literal then
- Rewrite (Hi,
- Make_Attribute_Reference (Sloc (Hi),
- Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (T, Sloc (Hi))));
- Analyze_And_Resolve (Hi);
- end if;
+ begin
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- -- If bounds aren't scalar at this point then exit, avoiding
- -- problems with further processing of the range in this procedure.
+ if Comes_From_Source (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ then
+ Wrap_Spec :=
+ Make_Subprogram_Declaration (Sloc (Prim),
+ Specification =>
+ Build_Wrapper_Spec
+ (Subp_Id => Prim,
+ Obj_Typ => Conc_Typ,
+ Formals =>
+ Parameter_Specifications (
+ Parent (Prim))));
- if not Is_Scalar_Type (Etype (Lo)) then
- return;
- end if;
+ Insert_After (Curr_Nod, Wrap_Spec);
+ Curr_Nod := Wrap_Spec;
- -- Resolve (actually Sem_Eval) has checked that the bounds are in
- -- then range of the base type. Here we check whether the bounds
- -- are in the range of the subtype itself. Note that if the bounds
- -- represent the null range the Constraint_Error exception should
- -- not be raised.
+ Analyze (Wrap_Spec);
+ end if;
- -- ??? The following code should be cleaned up as follows
+ Next_Elmt (Prim_Elmt);
+ end loop;
- -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
- -- is done in the call to Range_Check (R, T); below
+ return;
+ end;
- -- 2. The use of R_Check_Off should be investigated and possibly
- -- removed, this would clean up things a bit.
+ -- For non-concurrent types, transfer explicit primitives, but
+ -- omit those inherited from the parent of the private view
+ -- since they will be re-inherited later on.
- if Is_Null_Range (Lo, Hi) then
- null;
+ else
+ Full_List := Primitive_Operations (Full_T);
- else
- -- Capture values of bounds and generate temporaries for them
- -- if needed, before applying checks, since checks may cause
- -- duplication of the expression without forcing evaluation.
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- -- The forced evaluation removes side effects from expressions,
- -- which should occur also in GNATprove mode. Otherwise, we end up
- -- with unexpected insertions of actions at places where this is
- -- not supposed to occur, e.g. on default parameters of a call.
+ if Comes_From_Source (Prim)
+ and then not Contains (Prim, Full_List)
+ then
+ Append_Elmt (Prim, Full_List);
+ end if;
- if Expander_Active or GNATprove_Mode then
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
- -- If no subtype name, then just call Force_Evaluation to
- -- create declarations as needed to deal with side effects.
- -- Also ignore calls from within a record type, where we
- -- have possible scoping issues.
+ -- Untagged private view
- if No (Subtyp) or else Is_Record_Type (Current_Scope) then
- Force_Evaluation (Lo);
- Force_Evaluation (Hi);
+ else
+ Full_List := Primitive_Operations (Full_T);
- -- If a subtype is given, then we capture the bounds if they
- -- are not known at compile time, using constant identifiers
- -- xxx_FIRST and xxx_LAST where xxx is the name of the subtype.
+ -- In this case the partial view is untagged, so here we locate
+ -- all of the earlier primitives that need to be treated as
+ -- dispatching (those that appear between the two views). Note
+ -- that these additional operations must all be new operations
+ -- (any earlier operations that override inherited operations
+ -- of the full view will already have been inserted in the
+ -- primitives list, marked by Check_Operation_From_Private_View
+ -- as dispatching. Note that implicit "/=" operators are
+ -- excluded from being added to the primitives list since they
+ -- shouldn't be treated as dispatching (tagged "/=" is handled
+ -- specially).
- -- Note: we do this transformation even if expansion is not
- -- active, and in particular we do it in GNATprove_Mode since
- -- the transformation is in general required to ensure that the
- -- resulting tree has proper Ada semantics.
+ Prim := Next_Entity (Full_T);
+ while Present (Prim) and then Prim /= Priv_T loop
+ if Ekind_In (Prim, E_Procedure, E_Function) then
+ Disp_Typ := Find_Dispatching_Type (Prim);
- -- Historical note: We used to just do Force_Evaluation calls
- -- in all cases, but it is better to capture the bounds with
- -- proper non-serialized names, since these will be accessed
- -- from other units, and hence may be public, and also we can
- -- then expand 'First and 'Last references to be references to
- -- these special names.
+ if Disp_Typ = Full_T
+ and then (Chars (Prim) /= Name_Op_Ne
+ or else Comes_From_Source (Prim))
+ then
+ Check_Controlling_Formals (Full_T, Prim);
+
+ if not Is_Dispatching_Operation (Prim) then
+ Append_Elmt (Prim, Full_List);
+ Set_Is_Dispatching_Operation (Prim, True);
+ Set_DT_Position (Prim, No_Uint);
+ end if;
- else
- if not Compile_Time_Known_Value (Lo)
+ elsif Is_Dispatching_Operation (Prim)
+ and then Disp_Typ /= Full_T
+ then
- -- No need to capture bounds if they already are
- -- references to constants.
+ -- Verify that it is not otherwise controlled by a
+ -- formal or a return value of type T.
- and then not (Is_Entity_Name (Lo)
- and then Is_Constant_Object (Entity (Lo)))
- then
- declare
- Loc : constant Source_Ptr := Sloc (Lo);
- Lov : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Chars (Subtyp), "_FIRST"));
- begin
- Insert_Action (R,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Lov,
- Object_Definition =>
- New_Occurrence_Of (Base_Type (T), Loc),
- Constant_Present => True,
- Expression => Relocate_Node (Lo)));
- Rewrite (Lo, New_Occurrence_Of (Lov, Loc));
- end;
+ Check_Controlling_Formals (Disp_Typ, Prim);
+ end if;
end if;
- if not Compile_Time_Known_Value (Hi)
- and then not (Is_Entity_Name (Hi)
- and then Is_Constant_Object (Entity (Hi)))
- then
- declare
- Loc : constant Source_Ptr := Sloc (Hi);
- Hiv : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Chars (Subtyp), "_LAST"));
- begin
- Insert_Action (R,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Hiv,
- Object_Definition =>
- New_Occurrence_Of (Base_Type (T), Loc),
- Constant_Present => True,
- Expression => Relocate_Node (Hi)));
- Rewrite (Hi, New_Occurrence_Of (Hiv, Loc));
- end;
- end if;
- end if;
+ Next_Entity (Prim);
+ end loop;
end if;
- -- We use a flag here instead of suppressing checks on the
- -- type because the type we check against isn't necessarily
- -- the place where we put the check.
+ -- For the tagged case, the two views can share the same primitive
+ -- operations list and the same class-wide type. Update attributes
+ -- of the class-wide type which depend on the full declaration.
- if not R_Check_Off then
- R_Checks := Get_Range_Checks (R, T);
+ if Is_Tagged_Type (Priv_T) then
+ Set_Direct_Primitive_Operations (Priv_T, Full_List);
+ Set_Class_Wide_Type
+ (Base_Type (Full_T), Class_Wide_Type (Priv_T));
- -- Look up tree to find an appropriate insertion point. We
- -- can't just use insert_actions because later processing
- -- depends on the insertion node. Prior to Ada 2012 the
- -- insertion point could only be a declaration or a loop, but
- -- quantified expressions can appear within any context in an
- -- expression, and the insertion point can be any statement,
- -- pragma, or declaration.
+ Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
+ Set_Has_Protected
+ (Class_Wide_Type (Priv_T), Has_Protected (Full_T));
+ end if;
+ end;
+ end if;
- Insert_Node := Parent (R);
- while Present (Insert_Node) loop
- exit when
- Nkind (Insert_Node) in N_Declaration
- and then
- not Nkind_In
- (Insert_Node, N_Component_Declaration,
- N_Loop_Parameter_Specification,
- N_Function_Specification,
- N_Procedure_Specification);
+ -- Ada 2005 AI 161: Check preelaborable initialization consistency
- exit when Nkind (Insert_Node) in N_Later_Decl_Item
- or else Nkind (Insert_Node) in
- N_Statement_Other_Than_Procedure_Call
- or else Nkind_In (Insert_Node, N_Procedure_Call_Statement,
- N_Pragma);
+ if Known_To_Have_Preelab_Init (Priv_T) then
- Insert_Node := Parent (Insert_Node);
- end loop;
+ -- Case where there is a pragma Preelaborable_Initialization. We
+ -- always allow this in predefined units, which is cheating a bit,
+ -- but it means we don't have to struggle to meet the requirements in
+ -- the RM for having Preelaborable Initialization. Otherwise we
+ -- require that the type meets the RM rules. But we can't check that
+ -- yet, because of the rule about overriding Initialize, so we simply
+ -- set a flag that will be checked at freeze time.
- -- Why would Type_Decl not be present??? Without this test,
- -- short regression tests fail.
+ if not In_Predefined_Unit (Full_T) then
+ Set_Must_Have_Preelab_Init (Full_T);
+ end if;
+ end if;
- if Present (Insert_Node) then
+ -- If pragma CPP_Class was applied to the private type declaration,
+ -- propagate it now to the full type declaration.
- -- Case of loop statement. Verify that the range is part
- -- of the subtype indication of the iteration scheme.
+ if Is_CPP_Class (Priv_T) then
+ Set_Is_CPP_Class (Full_T);
+ Set_Convention (Full_T, Convention_CPP);
- if Nkind (Insert_Node) = N_Loop_Statement then
- declare
- Indic : Node_Id;
+ -- Check that components of imported CPP types do not have default
+ -- expressions.
- begin
- Indic := Parent (R);
- while Present (Indic)
- and then Nkind (Indic) /= N_Subtype_Indication
- loop
- Indic := Parent (Indic);
- end loop;
+ Check_CPP_Type_Has_No_Defaults (Full_T);
+ end if;
- if Present (Indic) then
- Def_Id := Etype (Subtype_Mark (Indic));
+ -- If the private view has user specified stream attributes, then so has
+ -- the full view.
- Insert_Range_Checks
- (R_Checks,
- Insert_Node,
- Def_Id,
- Sloc (Insert_Node),
- R,
- Do_Before => True);
- end if;
- end;
+ -- Why the test, how could these flags be already set in Full_T ???
- -- Insertion before a declaration. If the declaration
- -- includes discriminants, the list of applicable checks
- -- is given by the caller.
+ if Has_Specified_Stream_Read (Priv_T) then
+ Set_Has_Specified_Stream_Read (Full_T);
+ end if;
- elsif Nkind (Insert_Node) in N_Declaration then
- Def_Id := Defining_Identifier (Insert_Node);
+ if Has_Specified_Stream_Write (Priv_T) then
+ Set_Has_Specified_Stream_Write (Full_T);
+ end if;
- if (Ekind (Def_Id) = E_Record_Type
- and then Depends_On_Discriminant (R))
- or else
- (Ekind (Def_Id) = E_Protected_Type
- and then Has_Discriminants (Def_Id))
- then
- Append_Range_Checks
- (R_Checks,
- Check_List, Def_Id, Sloc (Insert_Node), R);
+ if Has_Specified_Stream_Input (Priv_T) then
+ Set_Has_Specified_Stream_Input (Full_T);
+ end if;
- else
- Insert_Range_Checks
- (R_Checks,
- Insert_Node, Def_Id, Sloc (Insert_Node), R);
+ if Has_Specified_Stream_Output (Priv_T) then
+ Set_Has_Specified_Stream_Output (Full_T);
+ end if;
- end if;
+ -- Propagate the attributes related to pragma Default_Initial_Condition
+ -- from the private to the full view. Note that both flags are mutually
+ -- exclusive.
- -- Insertion before a statement. Range appears in the
- -- context of a quantified expression. Insertion will
- -- take place when expression is expanded.
+ if Has_Default_Init_Cond (Priv_T)
+ or else Has_Inherited_Default_Init_Cond (Priv_T)
+ then
+ Propagate_Default_Init_Cond_Attributes
+ (From_Typ => Priv_T,
+ To_Typ => Full_T,
+ Private_To_Full_View => True);
+
+ -- In the case where the full view is derived from another private type,
+ -- the attributes related to pragma Default_Initial_Condition must be
+ -- propagated from the full to the private view to maintain consistency
+ -- of views.
+
+ -- package Pack is
+ -- type Parent_Typ is private
+ -- with Default_Initial_Condition ...;
+ -- private
+ -- type Parent_Typ is ...;
+ -- end Pack;
+
+ -- with Pack; use Pack;
+ -- package Pack_2 is
+ -- type Deriv_Typ is private; -- must inherit
+ -- private
+ -- type Deriv_Typ is new Parent_Typ; -- must inherit
+ -- end Pack_2;
+
+ elsif Has_Default_Init_Cond (Full_T)
+ or else Has_Inherited_Default_Init_Cond (Full_T)
+ then
+ Propagate_Default_Init_Cond_Attributes
+ (From_Typ => Full_T,
+ To_Typ => Priv_T,
+ Private_To_Full_View => True);
+ end if;
- else
- null;
- end if;
- end if;
- end if;
+ -- Propagate invariants to full type
+
+ if Has_Invariants (Priv_T) then
+ Set_Has_Invariants (Full_T);
+ Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T));
+ end if;
+
+ if Has_Inheritable_Invariants (Priv_T) then
+ Set_Has_Inheritable_Invariants (Full_T);
+ end if;
+
+ -- Propagate predicates to full type, and predicate function if already
+ -- defined. It is not clear that this can actually happen? the partial
+ -- view cannot be frozen yet, and the predicate function has not been
+ -- built. Still it is a cheap check and seems safer to make it.
+
+ if Has_Predicates (Priv_T) then
+ if Present (Predicate_Function (Priv_T)) then
+ Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
end if;
- -- Case of other than an explicit N_Range node
+ Set_Has_Predicates (Full_T);
+ end if;
+ end Process_Full_View;
- -- The forced evaluation removes side effects from expressions, which
- -- should occur also in GNATprove mode. Otherwise, we end up with
- -- unexpected insertions of actions at places where this is not
- -- supposed to occur, e.g. on default parameters of a call.
+ -----------------------------------
+ -- Process_Incomplete_Dependents --
+ -----------------------------------
- elsif Expander_Active or GNATprove_Mode then
- Get_Index_Bounds (R, Lo, Hi);
- Force_Evaluation (Lo);
- Force_Evaluation (Hi);
+ procedure Process_Incomplete_Dependents
+ (N : Node_Id;
+ Full_T : Entity_Id;
+ Inc_T : Entity_Id)
+ is
+ Inc_Elmt : Elmt_Id;
+ Priv_Dep : Entity_Id;
+ New_Subt : Entity_Id;
+
+ Disc_Constraint : Elist_Id;
+
+ begin
+ if No (Private_Dependents (Inc_T)) then
+ return;
end if;
- end Process_Range_Expr_In_Decl;
- --------------------------------------
- -- Process_Real_Range_Specification --
- --------------------------------------
+ -- Itypes that may be generated by the completion of an incomplete
+ -- subtype are not used by the back-end and not attached to the tree.
+ -- They are created only for constraint-checking purposes.
- procedure Process_Real_Range_Specification (Def : Node_Id) is
- Spec : constant Node_Id := Real_Range_Specification (Def);
- Lo : Node_Id;
- Hi : Node_Id;
- Err : Boolean := False;
+ Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
+ while Present (Inc_Elmt) loop
+ Priv_Dep := Node (Inc_Elmt);
- procedure Analyze_Bound (N : Node_Id);
- -- Analyze and check one bound
+ if Ekind (Priv_Dep) = E_Subprogram_Type then
- -------------------
- -- Analyze_Bound --
- -------------------
+ -- An Access_To_Subprogram type may have a return type or a
+ -- parameter type that is incomplete. Replace with the full view.
- procedure Analyze_Bound (N : Node_Id) is
- begin
- Analyze_And_Resolve (N, Any_Real);
+ if Etype (Priv_Dep) = Inc_T then
+ Set_Etype (Priv_Dep, Full_T);
+ end if;
- if not Is_OK_Static_Expression (N) then
- Flag_Non_Static_Expr
- ("bound in real type definition is not static!", N);
- Err := True;
- end if;
- end Analyze_Bound;
+ declare
+ Formal : Entity_Id;
- -- Start of processing for Process_Real_Range_Specification
+ begin
+ Formal := First_Formal (Priv_Dep);
+ while Present (Formal) loop
+ if Etype (Formal) = Inc_T then
+ Set_Etype (Formal, Full_T);
+ end if;
- begin
- if Present (Spec) then
- Lo := Low_Bound (Spec);
- Hi := High_Bound (Spec);
- Analyze_Bound (Lo);
- Analyze_Bound (Hi);
+ Next_Formal (Formal);
+ end loop;
+ end;
- -- If error, clear away junk range specification
+ elsif Is_Overloadable (Priv_Dep) then
- if Err then
- Set_Real_Range_Specification (Def, Empty);
- end if;
- end if;
- end Process_Real_Range_Specification;
+ -- If a subprogram in the incomplete dependents list is primitive
+ -- for a tagged full type then mark it as a dispatching operation,
+ -- check whether it overrides an inherited subprogram, and check
+ -- restrictions on its controlling formals. Note that a protected
+ -- operation is never dispatching: only its wrapper operation
+ -- (which has convention Ada) is.
- ---------------------
- -- Process_Subtype --
- ---------------------
+ if Is_Tagged_Type (Full_T)
+ and then Is_Primitive (Priv_Dep)
+ and then Convention (Priv_Dep) /= Convention_Protected
+ then
+ Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
+ Set_Is_Dispatching_Operation (Priv_Dep);
+ Check_Controlling_Formals (Full_T, Priv_Dep);
+ end if;
- function Process_Subtype
- (S : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id := Empty;
- Suffix : Character := ' ') return Entity_Id
- is
- P : Node_Id;
- Def_Id : Entity_Id;
- Error_Node : Node_Id;
- Full_View_Id : Entity_Id;
- Subtype_Mark_Id : Entity_Id;
+ elsif Ekind (Priv_Dep) = E_Subprogram_Body then
- May_Have_Null_Exclusion : Boolean;
+ -- Can happen during processing of a body before the completion
+ -- of a TA type. Ignore, because spec is also on dependent list.
- procedure Check_Incomplete (T : Entity_Id);
- -- Called to verify that an incomplete type is not used prematurely
+ return;
- ----------------------
- -- Check_Incomplete --
- ----------------------
+ -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a
+ -- corresponding subtype of the full view.
- procedure Check_Incomplete (T : Entity_Id) is
- begin
- -- Ada 2005 (AI-412): Incomplete subtypes are legal
+ elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then
+ Set_Subtype_Indication
+ (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep)));
+ Set_Etype (Priv_Dep, Full_T);
+ Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
+ Set_Analyzed (Parent (Priv_Dep), False);
- if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
- and then
- not (Ada_Version >= Ada_2005
- and then
- (Nkind (Parent (T)) = N_Subtype_Declaration
- or else
- (Nkind (Parent (T)) = N_Subtype_Indication
- and then Nkind (Parent (Parent (T))) =
- N_Subtype_Declaration)))
- then
- Error_Msg_N ("invalid use of type before its full declaration", T);
- end if;
- end Check_Incomplete;
+ -- Reanalyze the declaration, suppressing the call to
+ -- Enter_Name to avoid duplicate names.
- -- Start of processing for Process_Subtype
+ Analyze_Subtype_Declaration
+ (N => Parent (Priv_Dep),
+ Skip => True);
- begin
- -- Case of no constraints present
+ -- Dependent is a subtype
- if Nkind (S) /= N_Subtype_Indication then
- Find_Type (S);
- Check_Incomplete (S);
- P := Parent (S);
+ else
+ -- We build a new subtype indication using the full view of the
+ -- incomplete parent. The discriminant constraints have been
+ -- elaborated already at the point of the subtype declaration.
- -- Ada 2005 (AI-231): Static check
+ New_Subt := Create_Itype (E_Void, N);
- if Ada_Version >= Ada_2005
- and then Present (P)
- and then Null_Exclusion_Present (P)
- and then Nkind (P) /= N_Access_To_Object_Definition
- and then not Is_Access_Type (Entity (S))
- then
- Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
+ if Has_Discriminants (Full_T) then
+ Disc_Constraint := Discriminant_Constraint (Priv_Dep);
+ else
+ Disc_Constraint := No_Elist;
+ end if;
+
+ Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
+ Set_Full_View (Priv_Dep, New_Subt);
end if;
- -- The following is ugly, can't we have a range or even a flag???
+ Next_Elmt (Inc_Elmt);
+ end loop;
+ end Process_Incomplete_Dependents;
- May_Have_Null_Exclusion :=
- Nkind_In (P, N_Access_Definition,
- N_Access_Function_Definition,
- N_Access_Procedure_Definition,
- N_Access_To_Object_Definition,
- N_Allocator,
- N_Component_Definition)
- or else
- Nkind_In (P, N_Derived_Type_Definition,
- N_Discriminant_Specification,
- N_Formal_Object_Declaration,
- N_Object_Declaration,
- N_Object_Renaming_Declaration,
- N_Parameter_Specification,
- N_Subtype_Declaration);
+ --------------------------------
+ -- Process_Range_Expr_In_Decl --
+ --------------------------------
- -- Create an Itype that is a duplicate of Entity (S) but with the
- -- null-exclusion attribute.
+ procedure Process_Range_Expr_In_Decl
+ (R : Node_Id;
+ T : Entity_Id;
+ Subtyp : Entity_Id := Empty;
+ Check_List : List_Id := Empty_List;
+ R_Check_Off : Boolean := False;
+ In_Iter_Schm : Boolean := False)
+ is
+ Lo, Hi : Node_Id;
+ R_Checks : Check_Result;
+ Insert_Node : Node_Id;
+ Def_Id : Entity_Id;
- if May_Have_Null_Exclusion
- and then Is_Access_Type (Entity (S))
- and then Null_Exclusion_Present (P)
+ begin
+ Analyze_And_Resolve (R, Base_Type (T));
- -- No need to check the case of an access to object definition.
- -- It is correct to define double not-null pointers.
+ if Nkind (R) = N_Range then
- -- Example:
- -- type Not_Null_Int_Ptr is not null access Integer;
- -- type Acc is not null access Not_Null_Int_Ptr;
+ -- In SPARK, all ranges should be static, with the exception of the
+ -- discrete type definition of a loop parameter specification.
- and then Nkind (P) /= N_Access_To_Object_Definition
+ if not In_Iter_Schm
+ and then not Is_OK_Static_Range (R)
then
- if Can_Never_Be_Null (Entity (S)) then
- case Nkind (Related_Nod) is
- when N_Full_Type_Declaration =>
- if Nkind (Type_Definition (Related_Nod))
- in N_Array_Type_Definition
- then
- Error_Node :=
- Subtype_Indication
- (Component_Definition
- (Type_Definition (Related_Nod)));
- else
- Error_Node :=
- Subtype_Indication (Type_Definition (Related_Nod));
- end if;
+ Check_SPARK_05_Restriction ("range should be static", R);
+ end if;
- when N_Subtype_Declaration =>
- Error_Node := Subtype_Indication (Related_Nod);
+ Lo := Low_Bound (R);
+ Hi := High_Bound (R);
- when N_Object_Declaration =>
- Error_Node := Object_Definition (Related_Nod);
+ -- We need to ensure validity of the bounds here, because if we
+ -- go ahead and do the expansion, then the expanded code will get
+ -- analyzed with range checks suppressed and we miss the check.
+ -- Validity checks on the range of a quantified expression are
+ -- delayed until the construct is transformed into a loop.
- when N_Component_Declaration =>
- Error_Node :=
- Subtype_Indication (Component_Definition (Related_Nod));
+ if Nkind (Parent (R)) /= N_Loop_Parameter_Specification
+ or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression
+ then
+ Validity_Check_Range (R);
+ end if;
- when N_Allocator =>
- Error_Node := Expression (Related_Nod);
+ -- If there were errors in the declaration, try and patch up some
+ -- common mistakes in the bounds. The cases handled are literals
+ -- which are Integer where the expected type is Real and vice versa.
+ -- These corrections allow the compilation process to proceed further
+ -- along since some basic assumptions of the format of the bounds
+ -- are guaranteed.
- when others =>
- pragma Assert (False);
- Error_Node := Related_Nod;
- end case;
+ if Etype (R) = Any_Type then
+ if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then
+ Rewrite (Lo,
+ Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo))));
- Error_Msg_NE
- ("`NOT NULL` not allowed (& already excludes null)",
- Error_Node,
- Entity (S));
+ elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
+ Rewrite (Hi,
+ Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
+
+ elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then
+ Rewrite (Lo,
+ Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo))));
+
+ elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then
+ Rewrite (Hi,
+ Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi))));
end if;
- Set_Etype (S,
- Create_Null_Excluding_Itype
- (T => Entity (S),
- Related_Nod => P));
- Set_Entity (S, Etype (S));
+ Set_Etype (Lo, T);
+ Set_Etype (Hi, T);
end if;
- return Entity (S);
-
- -- Case of constraint present, so that we have an N_Subtype_Indication
- -- node (this node is created only if constraints are present).
+ -- If the bounds of the range have been mistakenly given as string
+ -- literals (perhaps in place of character literals), then an error
+ -- has already been reported, but we rewrite the string literal as a
+ -- bound of the range's type to avoid blowups in later processing
+ -- that looks at static values.
- else
- Find_Type (Subtype_Mark (S));
+ if Nkind (Lo) = N_String_Literal then
+ Rewrite (Lo,
+ Make_Attribute_Reference (Sloc (Lo),
+ Attribute_Name => Name_First,
+ Prefix => New_Occurrence_Of (T, Sloc (Lo))));
+ Analyze_And_Resolve (Lo);
+ end if;
- if Nkind (Parent (S)) /= N_Access_To_Object_Definition
- and then not
- (Nkind (Parent (S)) = N_Subtype_Declaration
- and then Is_Itype (Defining_Identifier (Parent (S))))
- then
- Check_Incomplete (Subtype_Mark (S));
+ if Nkind (Hi) = N_String_Literal then
+ Rewrite (Hi,
+ Make_Attribute_Reference (Sloc (Hi),
+ Attribute_Name => Name_First,
+ Prefix => New_Occurrence_Of (T, Sloc (Hi))));
+ Analyze_And_Resolve (Hi);
end if;
- P := Parent (S);
- Subtype_Mark_Id := Entity (Subtype_Mark (S));
+ -- If bounds aren't scalar at this point then exit, avoiding
+ -- problems with further processing of the range in this procedure.
- -- Explicit subtype declaration case
+ if not Is_Scalar_Type (Etype (Lo)) then
+ return;
+ end if;
- if Nkind (P) = N_Subtype_Declaration then
- Def_Id := Defining_Identifier (P);
+ -- Resolve (actually Sem_Eval) has checked that the bounds are in
+ -- then range of the base type. Here we check whether the bounds
+ -- are in the range of the subtype itself. Note that if the bounds
+ -- represent the null range the Constraint_Error exception should
+ -- not be raised.
- -- Explicit derived type definition case
+ -- ??? The following code should be cleaned up as follows
- elsif Nkind (P) = N_Derived_Type_Definition then
- Def_Id := Defining_Identifier (Parent (P));
+ -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
+ -- is done in the call to Range_Check (R, T); below
- -- Implicit case, the Def_Id must be created as an implicit type.
- -- The one exception arises in the case of concurrent types, array
- -- and access types, where other subsidiary implicit types may be
- -- created and must appear before the main implicit type. In these
- -- cases we leave Def_Id set to Empty as a signal that Create_Itype
- -- has not yet been called to create Def_Id.
+ -- 2. The use of R_Check_Off should be investigated and possibly
+ -- removed, this would clean up things a bit.
+
+ if Is_Null_Range (Lo, Hi) then
+ null;
else
- if Is_Array_Type (Subtype_Mark_Id)
- or else Is_Concurrent_Type (Subtype_Mark_Id)
- or else Is_Access_Type (Subtype_Mark_Id)
- then
- Def_Id := Empty;
+ -- Capture values of bounds and generate temporaries for them
+ -- if needed, before applying checks, since checks may cause
+ -- duplication of the expression without forcing evaluation.
- -- For the other cases, we create a new unattached Itype,
- -- and set the indication to ensure it gets attached later.
+ -- The forced evaluation removes side effects from expressions,
+ -- which should occur also in GNATprove mode. Otherwise, we end up
+ -- with unexpected insertions of actions at places where this is
+ -- not supposed to occur, e.g. on default parameters of a call.
- else
- Def_Id :=
- Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
- end if;
- end if;
+ if Expander_Active or GNATprove_Mode then
- -- If the kind of constraint is invalid for this kind of type,
- -- then give an error, and then pretend no constraint was given.
+ -- If no subtype name, then just call Force_Evaluation to
+ -- create declarations as needed to deal with side effects.
+ -- Also ignore calls from within a record type, where we
+ -- have possible scoping issues.
- if not Is_Valid_Constraint_Kind
- (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
- then
- Error_Msg_N
- ("incorrect constraint for this kind of type", Constraint (S));
+ if No (Subtyp) or else Is_Record_Type (Current_Scope) then
+ Force_Evaluation (Lo);
+ Force_Evaluation (Hi);
- Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
+ -- If a subtype is given, then we capture the bounds if they
+ -- are not known at compile time, using constant identifiers
+ -- xxx_FIRST and xxx_LAST where xxx is the name of the subtype.
- -- Set Ekind of orphan itype, to prevent cascaded errors
+ -- Note: we do this transformation even if expansion is not
+ -- active, and in particular we do it in GNATprove_Mode since
+ -- the transformation is in general required to ensure that the
+ -- resulting tree has proper Ada semantics.
- if Present (Def_Id) then
- Set_Ekind (Def_Id, Ekind (Any_Type));
+ -- Historical note: We used to just do Force_Evaluation calls
+ -- in all cases, but it is better to capture the bounds with
+ -- proper non-serialized names, since these will be accessed
+ -- from other units, and hence may be public, and also we can
+ -- then expand 'First and 'Last references to be references to
+ -- these special names.
+
+ else
+ if not Compile_Time_Known_Value (Lo)
+
+ -- No need to capture bounds if they already are
+ -- references to constants.
+
+ and then not (Is_Entity_Name (Lo)
+ and then Is_Constant_Object (Entity (Lo)))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (Lo);
+ Lov : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (Chars (Subtyp), "_FIRST"));
+ begin
+ Insert_Action (R,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Lov,
+ Object_Definition =>
+ New_Occurrence_Of (Base_Type (T), Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Lo)));
+ Rewrite (Lo, New_Occurrence_Of (Lov, Loc));
+ end;
+ end if;
+
+ if not Compile_Time_Known_Value (Hi)
+ and then not (Is_Entity_Name (Hi)
+ and then Is_Constant_Object (Entity (Hi)))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (Hi);
+ Hiv : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (Chars (Subtyp), "_LAST"));
+ begin
+ Insert_Action (R,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Hiv,
+ Object_Definition =>
+ New_Occurrence_Of (Base_Type (T), Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Hi)));
+ Rewrite (Hi, New_Occurrence_Of (Hiv, Loc));
+ end;
+ end if;
+ end if;
end if;
- -- Make recursive call, having got rid of the bogus constraint
+ -- We use a flag here instead of suppressing checks on the
+ -- type because the type we check against isn't necessarily
+ -- the place where we put the check.
- return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
- end if;
+ if not R_Check_Off then
+ R_Checks := Get_Range_Checks (R, T);
- -- Remaining processing depends on type. Select on Base_Type kind to
- -- ensure getting to the concrete type kind in the case of a private
- -- subtype (needed when only doing semantic analysis).
+ -- Look up tree to find an appropriate insertion point. We
+ -- can't just use insert_actions because later processing
+ -- depends on the insertion node. Prior to Ada 2012 the
+ -- insertion point could only be a declaration or a loop, but
+ -- quantified expressions can appear within any context in an
+ -- expression, and the insertion point can be any statement,
+ -- pragma, or declaration.
- case Ekind (Base_Type (Subtype_Mark_Id)) is
- when Access_Kind =>
+ Insert_Node := Parent (R);
+ while Present (Insert_Node) loop
+ exit when
+ Nkind (Insert_Node) in N_Declaration
+ and then
+ not Nkind_In
+ (Insert_Node, N_Component_Declaration,
+ N_Loop_Parameter_Specification,
+ N_Function_Specification,
+ N_Procedure_Specification);
- -- If this is a constraint on a class-wide type, discard it.
- -- There is currently no way to express a partial discriminant
- -- constraint on a type with unknown discriminants. This is
- -- a pathology that the ACATS wisely decides not to test.
+ exit when Nkind (Insert_Node) in N_Later_Decl_Item
+ or else Nkind (Insert_Node) in
+ N_Statement_Other_Than_Procedure_Call
+ or else Nkind_In (Insert_Node, N_Procedure_Call_Statement,
+ N_Pragma);
- if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then
- if Comes_From_Source (S) then
- Error_Msg_N
- ("constraint on class-wide type ignored??",
- Constraint (S));
- end if;
+ Insert_Node := Parent (Insert_Node);
+ end loop;
- if Nkind (P) = N_Subtype_Declaration then
- Set_Subtype_Indication (P,
- New_Occurrence_Of (Subtype_Mark_Id, Sloc (S)));
- end if;
+ -- Why would Type_Decl not be present??? Without this test,
+ -- short regression tests fail.
- return Subtype_Mark_Id;
- end if;
+ if Present (Insert_Node) then
- Constrain_Access (Def_Id, S, Related_Nod);
+ -- Case of loop statement. Verify that the range is part
+ -- of the subtype indication of the iteration scheme.
- if Expander_Active
- and then Is_Itype (Designated_Type (Def_Id))
- and then Nkind (Related_Nod) = N_Subtype_Declaration
- and then not Is_Incomplete_Type (Designated_Type (Def_Id))
- then
- Build_Itype_Reference
- (Designated_Type (Def_Id), Related_Nod);
- end if;
+ if Nkind (Insert_Node) = N_Loop_Statement then
+ declare
+ Indic : Node_Id;
+
+ begin
+ Indic := Parent (R);
+ while Present (Indic)
+ and then Nkind (Indic) /= N_Subtype_Indication
+ loop
+ Indic := Parent (Indic);
+ end loop;
+
+ if Present (Indic) then
+ Def_Id := Etype (Subtype_Mark (Indic));
- when Array_Kind =>
- Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
+ Insert_Range_Checks
+ (R_Checks,
+ Insert_Node,
+ Def_Id,
+ Sloc (Insert_Node),
+ R,
+ Do_Before => True);
+ end if;
+ end;
- when Decimal_Fixed_Point_Kind =>
- Constrain_Decimal (Def_Id, S);
+ -- Insertion before a declaration. If the declaration
+ -- includes discriminants, the list of applicable checks
+ -- is given by the caller.
- when Enumeration_Kind =>
- Constrain_Enumeration (Def_Id, S);
- Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
+ elsif Nkind (Insert_Node) in N_Declaration then
+ Def_Id := Defining_Identifier (Insert_Node);
- when Ordinary_Fixed_Point_Kind =>
- Constrain_Ordinary_Fixed (Def_Id, S);
+ if (Ekind (Def_Id) = E_Record_Type
+ and then Depends_On_Discriminant (R))
+ or else
+ (Ekind (Def_Id) = E_Protected_Type
+ and then Has_Discriminants (Def_Id))
+ then
+ Append_Range_Checks
+ (R_Checks,
+ Check_List, Def_Id, Sloc (Insert_Node), R);
- when Float_Kind =>
- Constrain_Float (Def_Id, S);
+ else
+ Insert_Range_Checks
+ (R_Checks,
+ Insert_Node, Def_Id, Sloc (Insert_Node), R);
- when Integer_Kind =>
- Constrain_Integer (Def_Id, S);
- Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
+ end if;
- when E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- E_Incomplete_Type =>
- Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+ -- Insertion before a statement. Range appears in the
+ -- context of a quantified expression. Insertion will
+ -- take place when expression is expanded.
- if Ekind (Def_Id) = E_Incomplete_Type then
- Set_Private_Dependents (Def_Id, New_Elmt_List);
+ else
+ null;
+ end if;
end if;
+ end if;
+ end if;
- when Private_Kind =>
- Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
- Set_Private_Dependents (Def_Id, New_Elmt_List);
-
- -- In case of an invalid constraint prevent further processing
- -- since the type constructed is missing expected fields.
+ -- Case of other than an explicit N_Range node
- if Etype (Def_Id) = Any_Type then
- return Def_Id;
- end if;
+ -- The forced evaluation removes side effects from expressions, which
+ -- should occur also in GNATprove mode. Otherwise, we end up with
+ -- unexpected insertions of actions at places where this is not
+ -- supposed to occur, e.g. on default parameters of a call.
- -- If the full view is that of a task with discriminants,
- -- we must constrain both the concurrent type and its
- -- corresponding record type. Otherwise we will just propagate
- -- the constraint to the full view, if available.
+ elsif Expander_Active or GNATprove_Mode then
+ Get_Index_Bounds (R, Lo, Hi);
+ Force_Evaluation (Lo);
+ Force_Evaluation (Hi);
+ end if;
+ end Process_Range_Expr_In_Decl;
- if Present (Full_View (Subtype_Mark_Id))
- and then Has_Discriminants (Subtype_Mark_Id)
- and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id))
- then
- Full_View_Id :=
- Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+ --------------------------------------
+ -- Process_Real_Range_Specification --
+ --------------------------------------
- Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id));
- Constrain_Concurrent (Full_View_Id, S,
- Related_Nod, Related_Id, Suffix);
- Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
- Set_Full_View (Def_Id, Full_View_Id);
+ procedure Process_Real_Range_Specification (Def : Node_Id) is
+ Spec : constant Node_Id := Real_Range_Specification (Def);
+ Lo : Node_Id;
+ Hi : Node_Id;
+ Err : Boolean := False;
- -- Introduce an explicit reference to the private subtype,
- -- to prevent scope anomalies in gigi if first use appears
- -- in a nested context, e.g. a later function body.
- -- Should this be generated in other contexts than a full
- -- type declaration?
+ procedure Analyze_Bound (N : Node_Id);
+ -- Analyze and check one bound
- if Is_Itype (Def_Id)
- and then
- Nkind (Parent (P)) = N_Full_Type_Declaration
- then
- Build_Itype_Reference (Def_Id, Parent (P));
- end if;
+ -------------------
+ -- Analyze_Bound --
+ -------------------
- else
- Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
- end if;
+ procedure Analyze_Bound (N : Node_Id) is
+ begin
+ Analyze_And_Resolve (N, Any_Real);
- when Concurrent_Kind =>
- Constrain_Concurrent (Def_Id, S,
- Related_Nod, Related_Id, Suffix);
+ if not Is_OK_Static_Expression (N) then
+ Flag_Non_Static_Expr
+ ("bound in real type definition is not static!", N);
+ Err := True;
+ end if;
+ end Analyze_Bound;
- when others =>
- Error_Msg_N ("invalid subtype mark in subtype indication", S);
- end case;
+ -- Start of processing for Process_Real_Range_Specification
- -- Size and Convention are always inherited from the base type
+ begin
+ if Present (Spec) then
+ Lo := Low_Bound (Spec);
+ Hi := High_Bound (Spec);
+ Analyze_Bound (Lo);
+ Analyze_Bound (Hi);
- Set_Size_Info (Def_Id, (Subtype_Mark_Id));
- Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
+ -- If error, clear away junk range specification
- return Def_Id;
+ if Err then
+ Set_Real_Range_Specification (Def, Empty);
+ end if;
end if;
- end Process_Subtype;
+ end Process_Real_Range_Specification;
- ---------------------------------------
- -- Check_Anonymous_Access_Components --
- ---------------------------------------
+ ---------------------
+ -- Process_Subtype --
+ ---------------------
- procedure Check_Anonymous_Access_Components
- (Typ_Decl : Node_Id;
- Typ : Entity_Id;
- Prev : Entity_Id;
- Comp_List : Node_Id)
+ function Process_Subtype
+ (S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Suffix : Character := ' ') return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (Typ_Decl);
- Anon_Access : Entity_Id;
- Acc_Def : Node_Id;
- Comp : Node_Id;
- Comp_Def : Node_Id;
- Decl : Node_Id;
- Type_Def : Node_Id;
+ P : Node_Id;
+ Def_Id : Entity_Id;
+ Error_Node : Node_Id;
+ Full_View_Id : Entity_Id;
+ Subtype_Mark_Id : Entity_Id;
- procedure Build_Incomplete_Type_Declaration;
- -- If the record type contains components that include an access to the
- -- current record, then create an incomplete type declaration for the
- -- record, to be used as the designated type of the anonymous access.
- -- This is done only once, and only if there is no previous partial
- -- view of the type.
+ May_Have_Null_Exclusion : Boolean;
- function Designates_T (Subt : Node_Id) return Boolean;
- -- Check whether a node designates the enclosing record type, or 'Class
- -- of that type
+ procedure Check_Incomplete (T : Entity_Id);
+ -- Called to verify that an incomplete type is not used prematurely
- function Mentions_T (Acc_Def : Node_Id) return Boolean;
- -- Check whether an access definition includes a reference to
- -- the enclosing record type. The reference can be a subtype mark
- -- in the access definition itself, a 'Class attribute reference, or
- -- recursively a reference appearing in a parameter specification
- -- or result definition of an access_to_subprogram definition.
+ ----------------------
+ -- Check_Incomplete --
+ ----------------------
- --------------------------------------
- -- Build_Incomplete_Type_Declaration --
- --------------------------------------
+ procedure Check_Incomplete (T : Entity_Id) is
+ begin
+ -- Ada 2005 (AI-412): Incomplete subtypes are legal
- procedure Build_Incomplete_Type_Declaration is
- Decl : Node_Id;
- Inc_T : Entity_Id;
- H : Entity_Id;
+ if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
+ and then
+ not (Ada_Version >= Ada_2005
+ and then
+ (Nkind (Parent (T)) = N_Subtype_Declaration
+ or else
+ (Nkind (Parent (T)) = N_Subtype_Indication
+ and then Nkind (Parent (Parent (T))) =
+ N_Subtype_Declaration)))
+ then
+ Error_Msg_N ("invalid use of type before its full declaration", T);
+ end if;
+ end Check_Incomplete;
- -- Is_Tagged indicates whether the type is tagged. It is tagged if
- -- it's "is new ... with record" or else "is tagged record ...".
+ -- Start of processing for Process_Subtype
- Is_Tagged : constant Boolean :=
- (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
- and then
- Present
- (Record_Extension_Part (Type_Definition (Typ_Decl))))
- or else
- (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition
- and then Tagged_Present (Type_Definition (Typ_Decl)));
+ begin
+ -- Case of no constraints present
- begin
- -- If there is a previous partial view, no need to create a new one
- -- If the partial view, given by Prev, is incomplete, If Prev is
- -- a private declaration, full declaration is flagged accordingly.
+ if Nkind (S) /= N_Subtype_Indication then
+ Find_Type (S);
+ Check_Incomplete (S);
+ P := Parent (S);
- if Prev /= Typ then
- if Is_Tagged then
- Make_Class_Wide_Type (Prev);
- Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev));
- Set_Etype (Class_Wide_Type (Typ), Typ);
- end if;
+ -- Ada 2005 (AI-231): Static check
+
+ if Ada_Version >= Ada_2005
+ and then Present (P)
+ and then Null_Exclusion_Present (P)
+ and then Nkind (P) /= N_Access_To_Object_Definition
+ and then not Is_Access_Type (Entity (S))
+ then
+ Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
+ end if;
- return;
+ -- The following is ugly, can't we have a range or even a flag???
- elsif Has_Private_Declaration (Typ) then
+ May_Have_Null_Exclusion :=
+ Nkind_In (P, N_Access_Definition,
+ N_Access_Function_Definition,
+ N_Access_Procedure_Definition,
+ N_Access_To_Object_Definition,
+ N_Allocator,
+ N_Component_Definition)
+ or else
+ Nkind_In (P, N_Derived_Type_Definition,
+ N_Discriminant_Specification,
+ N_Formal_Object_Declaration,
+ N_Object_Declaration,
+ N_Object_Renaming_Declaration,
+ N_Parameter_Specification,
+ N_Subtype_Declaration);
- -- If we refer to T'Class inside T, and T is the completion of a
- -- private type, then we need to make sure the class-wide type
- -- exists.
+ -- Create an Itype that is a duplicate of Entity (S) but with the
+ -- null-exclusion attribute.
- if Is_Tagged then
- Make_Class_Wide_Type (Typ);
- end if;
+ if May_Have_Null_Exclusion
+ and then Is_Access_Type (Entity (S))
+ and then Null_Exclusion_Present (P)
- return;
+ -- No need to check the case of an access to object definition.
+ -- It is correct to define double not-null pointers.
- -- If there was a previous anonymous access type, the incomplete
- -- type declaration will have been created already.
+ -- Example:
+ -- type Not_Null_Int_Ptr is not null access Integer;
+ -- type Acc is not null access Not_Null_Int_Ptr;
- elsif Present (Current_Entity (Typ))
- and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
- and then Full_View (Current_Entity (Typ)) = Typ
+ and then Nkind (P) /= N_Access_To_Object_Definition
then
- if Is_Tagged
- and then Comes_From_Source (Current_Entity (Typ))
- and then not Is_Tagged_Type (Current_Entity (Typ))
- then
- Make_Class_Wide_Type (Typ);
- Error_Msg_N
- ("incomplete view of tagged type should be declared tagged??",
- Parent (Current_Entity (Typ)));
- end if;
- return;
+ if Can_Never_Be_Null (Entity (S)) then
+ case Nkind (Related_Nod) is
+ when N_Full_Type_Declaration =>
+ if Nkind (Type_Definition (Related_Nod))
+ in N_Array_Type_Definition
+ then
+ Error_Node :=
+ Subtype_Indication
+ (Component_Definition
+ (Type_Definition (Related_Nod)));
+ else
+ Error_Node :=
+ Subtype_Indication (Type_Definition (Related_Nod));
+ end if;
- else
- Inc_T := Make_Defining_Identifier (Loc, Chars (Typ));
- Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T);
+ when N_Subtype_Declaration =>
+ Error_Node := Subtype_Indication (Related_Nod);
- -- Type has already been inserted into the current scope. Remove
- -- it, and add incomplete declaration for type, so that subsequent
- -- anonymous access types can use it. The entity is unchained from
- -- the homonym list and from immediate visibility. After analysis,
- -- the entity in the incomplete declaration becomes immediately
- -- visible in the record declaration that follows.
+ when N_Object_Declaration =>
+ Error_Node := Object_Definition (Related_Nod);
- H := Current_Entity (Typ);
+ when N_Component_Declaration =>
+ Error_Node :=
+ Subtype_Indication (Component_Definition (Related_Nod));
- if H = Typ then
- Set_Name_Entity_Id (Chars (Typ), Homonym (Typ));
- else
- while Present (H)
- and then Homonym (H) /= Typ
- loop
- H := Homonym (Typ);
- end loop;
+ when N_Allocator =>
+ Error_Node := Expression (Related_Nod);
- Set_Homonym (H, Homonym (Typ));
+ when others =>
+ pragma Assert (False);
+ Error_Node := Related_Nod;
+ end case;
+
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ Error_Node,
+ Entity (S));
end if;
- Insert_Before (Typ_Decl, Decl);
- Analyze (Decl);
- Set_Full_View (Inc_T, Typ);
+ Set_Etype (S,
+ Create_Null_Excluding_Itype
+ (T => Entity (S),
+ Related_Nod => P));
+ Set_Entity (S, Etype (S));
+ end if;
- if Is_Tagged then
+ return Entity (S);
- -- Create a common class-wide type for both views, and set the
- -- Etype of the class-wide type to the full view.
+ -- Case of constraint present, so that we have an N_Subtype_Indication
+ -- node (this node is created only if constraints are present).
- Make_Class_Wide_Type (Inc_T);
- Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T));
- Set_Etype (Class_Wide_Type (Typ), Typ);
- end if;
+ else
+ Find_Type (Subtype_Mark (S));
+
+ if Nkind (Parent (S)) /= N_Access_To_Object_Definition
+ and then not
+ (Nkind (Parent (S)) = N_Subtype_Declaration
+ and then Is_Itype (Defining_Identifier (Parent (S))))
+ then
+ Check_Incomplete (Subtype_Mark (S));
end if;
- end Build_Incomplete_Type_Declaration;
- ------------------
- -- Designates_T --
- ------------------
+ P := Parent (S);
+ Subtype_Mark_Id := Entity (Subtype_Mark (S));
- function Designates_T (Subt : Node_Id) return Boolean is
- Type_Id : constant Name_Id := Chars (Typ);
+ -- Explicit subtype declaration case
- function Names_T (Nam : Node_Id) return Boolean;
- -- The record type has not been introduced in the current scope
- -- yet, so we must examine the name of the type itself, either
- -- an identifier T, or an expanded name of the form P.T, where
- -- P denotes the current scope.
+ if Nkind (P) = N_Subtype_Declaration then
+ Def_Id := Defining_Identifier (P);
- -------------
- -- Names_T --
- -------------
+ -- Explicit derived type definition case
- function Names_T (Nam : Node_Id) return Boolean is
- begin
- if Nkind (Nam) = N_Identifier then
- return Chars (Nam) = Type_Id;
+ elsif Nkind (P) = N_Derived_Type_Definition then
+ Def_Id := Defining_Identifier (Parent (P));
- elsif Nkind (Nam) = N_Selected_Component then
- if Chars (Selector_Name (Nam)) = Type_Id then
- if Nkind (Prefix (Nam)) = N_Identifier then
- return Chars (Prefix (Nam)) = Chars (Current_Scope);
+ -- Implicit case, the Def_Id must be created as an implicit type.
+ -- The one exception arises in the case of concurrent types, array
+ -- and access types, where other subsidiary implicit types may be
+ -- created and must appear before the main implicit type. In these
+ -- cases we leave Def_Id set to Empty as a signal that Create_Itype
+ -- has not yet been called to create Def_Id.
- elsif Nkind (Prefix (Nam)) = N_Selected_Component then
- return Chars (Selector_Name (Prefix (Nam))) =
- Chars (Current_Scope);
- else
- return False;
- end if;
+ else
+ if Is_Array_Type (Subtype_Mark_Id)
+ or else Is_Concurrent_Type (Subtype_Mark_Id)
+ or else Is_Access_Type (Subtype_Mark_Id)
+ then
+ Def_Id := Empty;
- else
- return False;
- end if;
+ -- For the other cases, we create a new unattached Itype,
+ -- and set the indication to ensure it gets attached later.
else
- return False;
+ Def_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
end if;
- end Names_T;
-
- -- Start of processing for Designates_T
+ end if;
- begin
- if Nkind (Subt) = N_Identifier then
- return Chars (Subt) = Type_Id;
+ -- If the kind of constraint is invalid for this kind of type,
+ -- then give an error, and then pretend no constraint was given.
- -- Reference can be through an expanded name which has not been
- -- analyzed yet, and which designates enclosing scopes.
+ if not Is_Valid_Constraint_Kind
+ (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
+ then
+ Error_Msg_N
+ ("incorrect constraint for this kind of type", Constraint (S));
- elsif Nkind (Subt) = N_Selected_Component then
- if Names_T (Subt) then
- return True;
+ Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
- -- Otherwise it must denote an entity that is already visible.
- -- The access definition may name a subtype of the enclosing
- -- type, if there is a previous incomplete declaration for it.
+ -- Set Ekind of orphan itype, to prevent cascaded errors
- else
- Find_Selected_Component (Subt);
- return
- Is_Entity_Name (Subt)
- and then Scope (Entity (Subt)) = Current_Scope
- and then
- (Chars (Base_Type (Entity (Subt))) = Type_Id
- or else
- (Is_Class_Wide_Type (Entity (Subt))
- and then
- Chars (Etype (Base_Type (Entity (Subt)))) =
- Type_Id));
+ if Present (Def_Id) then
+ Set_Ekind (Def_Id, Ekind (Any_Type));
end if;
- -- A reference to the current type may appear as the prefix of
- -- a 'Class attribute.
-
- elsif Nkind (Subt) = N_Attribute_Reference
- and then Attribute_Name (Subt) = Name_Class
- then
- return Names_T (Prefix (Subt));
+ -- Make recursive call, having got rid of the bogus constraint
- else
- return False;
+ return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
end if;
- end Designates_T;
- ----------------
- -- Mentions_T --
- ----------------
+ -- Remaining processing depends on type. Select on Base_Type kind to
+ -- ensure getting to the concrete type kind in the case of a private
+ -- subtype (needed when only doing semantic analysis).
+
+ case Ekind (Base_Type (Subtype_Mark_Id)) is
+ when Access_Kind =>
+
+ -- If this is a constraint on a class-wide type, discard it.
+ -- There is currently no way to express a partial discriminant
+ -- constraint on a type with unknown discriminants. This is
+ -- a pathology that the ACATS wisely decides not to test.
+
+ if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then
+ if Comes_From_Source (S) then
+ Error_Msg_N
+ ("constraint on class-wide type ignored??",
+ Constraint (S));
+ end if;
- function Mentions_T (Acc_Def : Node_Id) return Boolean is
- Param_Spec : Node_Id;
+ if Nkind (P) = N_Subtype_Declaration then
+ Set_Subtype_Indication (P,
+ New_Occurrence_Of (Subtype_Mark_Id, Sloc (S)));
+ end if;
- Acc_Subprg : constant Node_Id :=
- Access_To_Subprogram_Definition (Acc_Def);
+ return Subtype_Mark_Id;
+ end if;
- begin
- if No (Acc_Subprg) then
- return Designates_T (Subtype_Mark (Acc_Def));
- end if;
+ Constrain_Access (Def_Id, S, Related_Nod);
- -- Component is an access_to_subprogram: examine its formals,
- -- and result definition in the case of an access_to_function.
+ if Expander_Active
+ and then Is_Itype (Designated_Type (Def_Id))
+ and then Nkind (Related_Nod) = N_Subtype_Declaration
+ and then not Is_Incomplete_Type (Designated_Type (Def_Id))
+ then
+ Build_Itype_Reference
+ (Designated_Type (Def_Id), Related_Nod);
+ end if;
- Param_Spec := First (Parameter_Specifications (Acc_Subprg));
- while Present (Param_Spec) loop
- if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition
- and then Mentions_T (Parameter_Type (Param_Spec))
- then
- return True;
+ when Array_Kind =>
+ Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
- elsif Designates_T (Parameter_Type (Param_Spec)) then
- return True;
- end if;
+ when Decimal_Fixed_Point_Kind =>
+ Constrain_Decimal (Def_Id, S);
- Next (Param_Spec);
- end loop;
+ when Enumeration_Kind =>
+ Constrain_Enumeration (Def_Id, S);
+ Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
- if Nkind (Acc_Subprg) = N_Access_Function_Definition then
- if Nkind (Result_Definition (Acc_Subprg)) =
- N_Access_Definition
- then
- return Mentions_T (Result_Definition (Acc_Subprg));
- else
- return Designates_T (Result_Definition (Acc_Subprg));
- end if;
- end if;
+ when Ordinary_Fixed_Point_Kind =>
+ Constrain_Ordinary_Fixed (Def_Id, S);
- return False;
- end Mentions_T;
+ when Float_Kind =>
+ Constrain_Float (Def_Id, S);
- -- Start of processing for Check_Anonymous_Access_Components
+ when Integer_Kind =>
+ Constrain_Integer (Def_Id, S);
+ Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
- begin
- if No (Comp_List) then
- return;
- end if;
+ when E_Record_Type |
+ E_Record_Subtype |
+ Class_Wide_Kind |
+ E_Incomplete_Type =>
+ Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
- Comp := First (Component_Items (Comp_List));
- while Present (Comp) loop
- if Nkind (Comp) = N_Component_Declaration
- and then Present
- (Access_Definition (Component_Definition (Comp)))
- and then
- Mentions_T (Access_Definition (Component_Definition (Comp)))
- then
- Comp_Def := Component_Definition (Comp);
- Acc_Def :=
- Access_To_Subprogram_Definition
- (Access_Definition (Comp_Def));
+ if Ekind (Def_Id) = E_Incomplete_Type then
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
+ end if;
- Build_Incomplete_Type_Declaration;
- Anon_Access := Make_Temporary (Loc, 'S');
+ when Private_Kind =>
+ Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
- -- Create a declaration for the anonymous access type: either
- -- an access_to_object or an access_to_subprogram.
+ -- In case of an invalid constraint prevent further processing
+ -- since the type constructed is missing expected fields.
- if Present (Acc_Def) then
- if Nkind (Acc_Def) = N_Access_Function_Definition then
- Type_Def :=
- Make_Access_Function_Definition (Loc,
- Parameter_Specifications =>
- Parameter_Specifications (Acc_Def),
- Result_Definition => Result_Definition (Acc_Def));
- else
- Type_Def :=
- Make_Access_Procedure_Definition (Loc,
- Parameter_Specifications =>
- Parameter_Specifications (Acc_Def));
+ if Etype (Def_Id) = Any_Type then
+ return Def_Id;
end if;
- else
- Type_Def :=
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- Relocate_Node
- (Subtype_Mark
- (Access_Definition (Comp_Def))));
+ -- If the full view is that of a task with discriminants,
+ -- we must constrain both the concurrent type and its
+ -- corresponding record type. Otherwise we will just propagate
+ -- the constraint to the full view, if available.
- Set_Constant_Present
- (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
- Set_All_Present
- (Type_Def, All_Present (Access_Definition (Comp_Def)));
- end if;
+ if Present (Full_View (Subtype_Mark_Id))
+ and then Has_Discriminants (Subtype_Mark_Id)
+ and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id))
+ then
+ Full_View_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
- Set_Null_Exclusion_Present
- (Type_Def,
- Null_Exclusion_Present (Access_Definition (Comp_Def)));
+ Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id));
+ Constrain_Concurrent (Full_View_Id, S,
+ Related_Nod, Related_Id, Suffix);
+ Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
+ Set_Full_View (Def_Id, Full_View_Id);
- Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Anon_Access,
- Type_Definition => Type_Def);
+ -- Introduce an explicit reference to the private subtype,
+ -- to prevent scope anomalies in gigi if first use appears
+ -- in a nested context, e.g. a later function body.
+ -- Should this be generated in other contexts than a full
+ -- type declaration?
- Insert_Before (Typ_Decl, Decl);
- Analyze (Decl);
+ if Is_Itype (Def_Id)
+ and then
+ Nkind (Parent (P)) = N_Full_Type_Declaration
+ then
+ Build_Itype_Reference (Def_Id, Parent (P));
+ end if;
- -- If an access to subprogram, create the extra formals
+ else
+ Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
+ end if;
- if Present (Acc_Def) then
- Create_Extra_Formals (Designated_Type (Anon_Access));
+ when Concurrent_Kind =>
+ Constrain_Concurrent (Def_Id, S,
+ Related_Nod, Related_Id, Suffix);
- -- If an access to object, preserve entity of designated type,
- -- for ASIS use, before rewriting the component definition.
+ when others =>
+ Error_Msg_N ("invalid subtype mark in subtype indication", S);
+ end case;
- else
- declare
- Desig : Entity_Id;
+ -- Size and Convention are always inherited from the base type
- begin
- Desig := Entity (Subtype_Indication (Type_Def));
+ Set_Size_Info (Def_Id, (Subtype_Mark_Id));
+ Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
- -- If the access definition is to the current record,
- -- the visible entity at this point is an incomplete
- -- type. Retrieve the full view to simplify ASIS queries
+ return Def_Id;
+ end if;
+ end Process_Subtype;
- if Ekind (Desig) = E_Incomplete_Type then
- Desig := Full_View (Desig);
- end if;
+ --------------------------------------------
+ -- Propagate_Default_Init_Cond_Attributes --
+ --------------------------------------------
- Set_Entity
- (Subtype_Mark (Access_Definition (Comp_Def)), Desig);
- end;
- end if;
+ procedure Propagate_Default_Init_Cond_Attributes
+ (From_Typ : Entity_Id;
+ To_Typ : Entity_Id;
+ Parent_To_Derivation : Boolean := False;
+ Private_To_Full_View : Boolean := False)
+ is
+ procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id);
+ -- Remove the default initial procedure (if any) from the rep chain of
+ -- type Typ.
- Rewrite (Comp_Def,
- Make_Component_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (Anon_Access, Loc)));
+ ----------------------------------------
+ -- Remove_Default_Init_Cond_Procedure --
+ ----------------------------------------
- if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
- Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
- else
- Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
- end if;
+ procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id) is
+ Found : Boolean := False;
+ Prev : Entity_Id;
+ Subp : Entity_Id;
- Set_Is_Local_Anonymous_Access (Anon_Access);
- end if;
+ begin
+ Prev := Typ;
+ Subp := Subprograms_For_Type (Typ);
+ while Present (Subp) loop
+ if Is_Default_Init_Cond_Procedure (Subp) then
+ Found := True;
+ exit;
+ end if;
- Next (Comp);
- end loop;
+ Prev := Subp;
+ Subp := Subprograms_For_Type (Subp);
+ end loop;
- if Present (Variant_Part (Comp_List)) then
- declare
- V : Node_Id;
- begin
- V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
- while Present (V) loop
- Check_Anonymous_Access_Components
- (Typ_Decl, Typ, Prev, Component_List (V));
- Next_Non_Pragma (V);
- end loop;
- end;
- end if;
- end Check_Anonymous_Access_Components;
+ if Found then
+ Set_Subprograms_For_Type (Prev, Subprograms_For_Type (Subp));
+ Set_Subprograms_For_Type (Subp, Empty);
+ end if;
+ end Remove_Default_Init_Cond_Procedure;
- ----------------------------------
- -- Preanalyze_Assert_Expression --
- ----------------------------------
+ -- Local variables
- procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is
- begin
- In_Assertion_Expr := In_Assertion_Expr + 1;
- Preanalyze_Spec_Expression (N, T);
- In_Assertion_Expr := In_Assertion_Expr - 1;
- end Preanalyze_Assert_Expression;
+ Inherit_Procedure : Boolean := False;
- -----------------------------------
- -- Preanalyze_Default_Expression --
- -----------------------------------
+ -- Start of processing for Propagate_Default_Init_Cond_Attributes
- procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is
- Save_In_Default_Expr : constant Boolean := In_Default_Expr;
begin
- In_Default_Expr := True;
- Preanalyze_Spec_Expression (N, T);
- In_Default_Expr := Save_In_Default_Expr;
- end Preanalyze_Default_Expression;
-
- --------------------------------
- -- Preanalyze_Spec_Expression --
- --------------------------------
+ -- A full view inherits the attributes from its private view
+
+ if Has_Default_Init_Cond (From_Typ) then
+ Set_Has_Default_Init_Cond (To_Typ);
+ Inherit_Procedure := True;
+
+ -- Due to the order of expansion, a derived private type is processed
+ -- by two routines which both attempt to set the attributes related
+ -- to pragma Default_Initial_Condition - Build_Derived_Type and then
+ -- Process_Full_View.
+
+ -- package Pack is
+ -- type Parent_Typ is private
+ -- with Default_Initial_Condition ...;
+ -- private
+ -- type Parent_Typ is ...;
+ -- end Pack;
+
+ -- with Pack; use Pack;
+ -- package Pack_2 is
+ -- type Deriv_Typ is private
+ -- with Default_Initial_Condition ...;
+ -- private
+ -- type Deriv_Typ is new Parent_Typ;
+ -- end Pack_2;
+
+ -- When Build_Derived_Type operates, it sets the attributes on the
+ -- full view without taking into account that the private view may
+ -- define its own default initial condition procedure. This becomes
+ -- apparent in Process_Full_View which must undo some of the work by
+ -- Build_Derived_Type and propagate the attributes from the private
+ -- to the full view.
+
+ if Private_To_Full_View then
+ Set_Has_Inherited_Default_Init_Cond (To_Typ, False);
+ Remove_Default_Init_Cond_Procedure (To_Typ);
+ end if;
+
+ -- A type must inherit the default initial condition procedure from a
+ -- parent type when the parent itself is inheriting the procedure or
+ -- when it is defining one. This circuitry is also used when dealing
+ -- with the private / full view of a type.
+
+ elsif Has_Inherited_Default_Init_Cond (From_Typ)
+ or (Parent_To_Derivation
+ and Present (Get_Pragma
+ (From_Typ, Pragma_Default_Initial_Condition)))
+ then
+ Set_Has_Inherited_Default_Init_Cond (To_Typ);
+ Inherit_Procedure := True;
+ end if;
- procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is
- Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
- begin
- In_Spec_Expression := True;
- Preanalyze_And_Resolve (N, T);
- In_Spec_Expression := Save_In_Spec_Expression;
- end Preanalyze_Spec_Expression;
+ if Inherit_Procedure
+ and then No (Default_Init_Cond_Procedure (To_Typ))
+ then
+ Set_Default_Init_Cond_Procedure
+ (To_Typ, Default_Init_Cond_Procedure (From_Typ));
+ end if;
+ end Propagate_Default_Init_Cond_Attributes;
-----------------------------
-- Record_Type_Declaration --
projects / gcc.git / commitdiff