with Atree; use Atree;
with Checks; use Checks;
with Elists; use Elists;
with Einfo; use Einfo;
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Ch3; use Exp_Ch3;
with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
with Layout; use Layout;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Smem; use Sem_Smem;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Urealp; use Urealp;
package body Sem_Ch3 is
procedure Build_Derived_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Is_Completion : Boolean;
Derive_Subps : Boolean := True);
procedure Build_Derived_Access_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id);
procedure Build_Derived_Array_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id);
procedure Build_Derived_Concurrent_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id);
procedure Build_Derived_Enumeration_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id);
procedure Build_Derived_Numeric_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id);
procedure Build_Derived_Private_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Is_Completion : Boolean;
Derive_Subps : Boolean := True);
procedure Build_Derived_Record_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Derive_Subps : Boolean := True);
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;
procedure Build_Discriminal (Discrim : Entity_Id);
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
Derived_Def : Boolean := False)
return Elist_Id;
procedure Build_Discriminated_Subtype
(T : Entity_Id;
Def_Id : Entity_Id;
Elist : Elist_Id;
Related_Nod : Node_Id;
For_Access : Boolean := False);
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
Der_T : Entity_Id)
return Node_Id;
procedure Build_Underlying_Full_View
(N : Node_Id;
Typ : Entity_Id;
Par : Entity_Id);
procedure Check_Access_Discriminant_Requires_Limited
(D : Node_Id;
Loc : Node_Id);
procedure Check_Delta_Expression (E : Node_Id);
procedure Check_Digits_Expression (E : Node_Id);
procedure Check_Incomplete (T : Entity_Id);
procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id);
procedure Check_Real_Bound (Bound : Node_Id);
procedure Constant_Redeclaration
(Id : Entity_Id;
N : Node_Id;
T : out Entity_Id);
procedure Convert_Scalar_Bounds
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Loc : Source_Ptr);
procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id);
procedure Create_Constrained_Components
(Subt : Entity_Id;
Decl_Node : Node_Id;
Typ : Entity_Id;
Constraints : Elist_Id);
function Constrain_Component_Type
(Compon_Type : Entity_Id;
Constrained_Typ : Entity_Id;
Related_Node : Node_Id;
Typ : Entity_Id;
Constraints : Elist_Id)
return Entity_Id;
procedure Constrain_Access
(Def_Id : in out Entity_Id;
S : Node_Id;
Related_Nod : Node_Id);
procedure Constrain_Array
(Def_Id : in out Entity_Id;
SI : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id;
Suffix : Character);
procedure Constrain_Concurrent
(Def_Id : in out Entity_Id;
SI : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id;
Suffix : Character);
function Constrain_Corresponding_Record
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id)
return Entity_Id;
procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id);
procedure Constrain_Discriminated_Type
(Def_Id : Entity_Id;
S : Node_Id;
Related_Nod : Node_Id;
For_Access : Boolean := False);
procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id);
procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id);
procedure Constrain_Index
(Index : Node_Id;
S : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id;
Suffix : Character;
Suffix_Index : Nat);
procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id);
procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id);
procedure Copy_And_Swap (Privat, Full : Entity_Id);
procedure Copy_Private_To_Full (Priv, Full : Entity_Id);
procedure Decimal_Fixed_Point_Type_Declaration
(T : Entity_Id;
Def : Node_Id);
procedure Complete_Private_Subtype
(Priv : Entity_Id;
Full : Entity_Id;
Full_Base : Entity_Id;
Related_Nod : Node_Id);
procedure Derived_Standard_Character
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id);
procedure Derived_Type_Declaration
(T : Entity_Id;
N : Node_Id;
Is_Completion : Boolean);
function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id;
procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id);
procedure Expand_Others_Choice
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
Choice_Type : Entity_Id);
function Find_Type_Of_Object
(Obj_Def : Node_Id;
Related_Nod : Node_Id)
return Entity_Id;
procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
function Has_Range_Constraint (N : Node_Id) return Boolean;
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
Constraint_Kind : Node_Kind)
return Boolean;
procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id);
procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id);
procedure Ordinary_Fixed_Point_Type_Declaration
(T : Entity_Id;
Def : Node_Id);
procedure Prepare_Private_Subtype_Completion
(Id : Entity_Id;
Related_Nod : Node_Id);
procedure Process_Incomplete_Dependents
(N : Node_Id;
Full_T : Entity_Id;
Inc_T : Entity_Id);
procedure Process_Real_Range_Specification (Def : Node_Id);
procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id);
procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id);
procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id);
procedure Set_Fixed_Range
(E : Entity_Id;
Loc : Source_Ptr;
Lo : Ureal;
Hi : Ureal);
procedure Set_Scalar_Range_For_Subtype
(Def_Id : Entity_Id;
R : Node_Id;
Subt : Entity_Id);
procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
function Access_Definition
(Related_Nod : Node_Id;
N : Node_Id)
return Entity_Id
is
Anon_Type : constant Entity_Id :=
Create_Itype (E_Anonymous_Access_Type, Related_Nod,
Scope_Id => Scope (Current_Scope));
Desig_Type : Entity_Id;
begin
if Is_Entry (Current_Scope)
and then Is_Task_Type (Etype (Scope (Current_Scope)))
then
Error_Msg_N ("task entries cannot have access parameters", N);
end if;
Find_Type (Subtype_Mark (N));
Desig_Type := Entity (Subtype_Mark (N));
Set_Directly_Designated_Type
(Anon_Type, Desig_Type);
Set_Etype (Anon_Type, Anon_Type);
Init_Size_Align (Anon_Type);
Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
if Ekind (Desig_Type) = E_Incomplete_Type
and then Is_Overloadable (Current_Scope)
then
Append_Elmt (Current_Scope, Private_Dependents (Desig_Type));
Set_Has_Delayed_Freeze (Current_Scope);
end if;
return Anon_Type;
end Access_Definition;
procedure Access_Subprogram_Declaration
(T_Name : Entity_Id;
T_Def : Node_Id)
is
Formals : constant List_Id := Parameter_Specifications (T_Def);
Formal : Entity_Id;
Desig_Type : constant Entity_Id :=
Create_Itype (E_Subprogram_Type, Parent (T_Def));
begin
if Nkind (T_Def) = N_Access_Function_Definition then
Analyze (Subtype_Mark (T_Def));
Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def)));
else
Set_Etype (Desig_Type, Standard_Void_Type);
end if;
if Present (Formals) then
New_Scope (Desig_Type);
Process_Formals (Formals, Parent (T_Def));
Set_Parent (Desig_Type, T_Name);
End_Scope;
Set_Parent (Desig_Type, Empty);
end if;
if Present (Formals) then
Formal := First_Formal (Desig_Type);
while Present (Formal) loop
if Ekind (Formal) /= E_In_Parameter
and then Nkind (T_Def) = N_Access_Function_Definition
then
Error_Msg_N ("functions can only have IN parameters", Formal);
end if;
if Ekind (Etype (Formal)) = E_Incomplete_Type then
Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal)));
Set_Has_Delayed_Freeze (Desig_Type);
end if;
Next_Formal (Formal);
end loop;
end if;
if Ekind (Etype (Desig_Type)) = E_Incomplete_Type
and then not Has_Delayed_Freeze (Desig_Type)
then
Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type)));
Set_Has_Delayed_Freeze (Desig_Type);
end if;
Check_Delayed_Subprogram (Desig_Type);
if Protected_Present (T_Def) then
Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type);
Set_Convention (Desig_Type, Convention_Protected);
else
Set_Ekind (T_Name, E_Access_Subprogram_Type);
end if;
Set_Etype (T_Name, T_Name);
Init_Size_Align (T_Name);
Set_Directly_Designated_Type (T_Name, Desig_Type);
Check_Restriction (No_Access_Subprograms, T_Def);
end Access_Subprogram_Declaration;
procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is
S : constant Node_Id := Subtype_Indication (Def);
P : constant Node_Id := Parent (Def);
begin
if Nkind (S) /= N_Subtype_Indication then
Analyze (S);
if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
Set_Directly_Designated_Type (T, Entity (S));
else
Set_Directly_Designated_Type (T,
Process_Subtype (S, P, T, 'P'));
end if;
else
Set_Directly_Designated_Type (T,
Process_Subtype (S, P, T, 'P'));
end if;
if All_Present (Def) or Constant_Present (Def) then
Set_Ekind (T, E_General_Access_Type);
else
Set_Ekind (T, E_Access_Type);
end if;
if Base_Type (Designated_Type (T)) = T then
Error_Msg_N ("access type cannot designate itself", S);
end if;
Set_Etype (T, T);
if not From_With_Type (T) then
Init_Size_Align (T);
end if;
Set_Is_Access_Constant (T, Constant_Present (Def));
if From_With_Type (Designated_Type (T)) then
Set_From_With_Type (T);
end if;
Set_Has_Task (T, False);
Set_Has_Controlled_Component (T, False);
end Access_Type_Declaration;
procedure Analyze_Component_Declaration (N : Node_Id) is
Id : constant Entity_Id := Defining_Identifier (N);
T : Entity_Id;
P : Entity_Id;
begin
Generate_Definition (Id);
Enter_Name (Id);
T := Find_Type_Of_Object (Subtype_Indication (N), N);
if Present (Expression (N)) then
Analyze_Default_Expression (Expression (N), T);
Check_Initialization (T, Expression (N));
end if;
if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
Error_Msg_N
("unconstrained subtype in component declaration",
Subtype_Indication (N));
elsif Is_Abstract (T) and then Chars (Id) /= Name_uParent then
Error_Msg_N ("type of a component cannot be abstract", N);
end if;
Set_Etype (Id, T);
Set_Is_Aliased (Id, Aliased_Present (N));
P := Private_Component (T);
if Present (P) then
if P = Any_Type then
Set_Etype (Id, Any_Type);
elsif Scope (P) = Scope (Current_Scope) then
null;
elsif Is_Limited_Type (P) then
Set_Is_Limited_Composite (Current_Scope);
else
Set_Is_Private_Composite (Current_Scope);
end if;
end if;
if P /= Any_Type
and then Is_Limited_Type (T)
and then Chars (Id) /= Name_uParent
and then Is_Tagged_Type (Current_Scope)
then
if Is_Derived_Type (Current_Scope)
and then not Is_Limited_Record (Root_Type (Current_Scope))
then
Error_Msg_N
("extension of nonlimited type cannot have limited components",
N);
Set_Etype (Id, Any_Type);
Set_Is_Limited_Composite (Current_Scope, False);
elsif not Is_Derived_Type (Current_Scope)
and then not Is_Limited_Record (Current_Scope)
then
Error_Msg_N ("nonlimited type cannot have limited components", N);
Set_Etype (Id, Any_Type);
Set_Is_Limited_Composite (Current_Scope, False);
end if;
end if;
Set_Original_Record_Component (Id, Id);
end Analyze_Component_Declaration;
procedure Analyze_Declarations (L : List_Id) is
D : Node_Id;
Next_Node : Node_Id;
Freeze_From : Entity_Id := Empty;
procedure Adjust_D;
procedure Adjust_D is
begin
while Present (Prev (D))
and then Nkind (D) = N_Implicit_Label_Declaration
loop
Prev (D);
end loop;
end Adjust_D;
begin
D := First (L);
while Present (D) loop
Analyze (D);
Next_Node := Next (D);
if No (Freeze_From) then
Freeze_From := First_Entity (Current_Scope);
end if;
if No (Next_Node) then
if Nkind (Parent (L)) = N_Component_List
or else Nkind (Parent (L)) = N_Task_Definition
or else Nkind (Parent (L)) = N_Protected_Definition
then
null;
elsif Nkind (Parent (L)) /= N_Package_Specification then
if Nkind (Parent (L)) = N_Package_Body then
Freeze_From := First_Entity (Current_Scope);
end if;
Adjust_D;
Freeze_All (Freeze_From, D);
Freeze_From := Last_Entity (Current_Scope);
elsif Scope (Current_Scope) /= Standard_Standard
and then not Is_Child_Unit (Current_Scope)
and then No (Generic_Parent (Parent (L)))
then
null;
elsif L /= Visible_Declarations (Parent (L))
or else No (Private_Declarations (Parent (L)))
or else Is_Empty_List (Private_Declarations (Parent (L)))
then
Adjust_D;
Freeze_All (Freeze_From, D);
Freeze_From := Last_Entity (Current_Scope);
end if;
elsif not Analyzed (Next_Node)
and then (Nkind (Next_Node) = N_Subprogram_Body
or else Nkind (Next_Node) = N_Entry_Body
or else Nkind (Next_Node) = N_Package_Body
or else Nkind (Next_Node) = N_Protected_Body
or else Nkind (Next_Node) = N_Task_Body
or else Nkind (Next_Node) in N_Body_Stub)
then
Adjust_D;
Freeze_All (Freeze_From, D);
Freeze_From := Last_Entity (Current_Scope);
end if;
D := Next_Node;
end loop;
end Analyze_Declarations;
procedure Analyze_Default_Expression (N : Node_Id; T : Entity_Id) is
Save_In_Default_Expression : constant Boolean := In_Default_Expression;
begin
In_Default_Expression := True;
Pre_Analyze_And_Resolve (N, T);
In_Default_Expression := Save_In_Default_Expression;
end Analyze_Default_Expression;
procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is
F : constant Boolean := Is_Pure (Current_Scope);
T : Entity_Id;
begin
Generate_Definition (Defining_Identifier (N));
T := Find_Type_Name (N);
Set_Ekind (T, E_Incomplete_Type);
Init_Size_Align (T);
Set_Is_First_Subtype (T, True);
Set_Etype (T, T);
New_Scope (T);
Set_Girder_Constraint (T, No_Elist);
if Present (Discriminant_Specifications (N)) then
Process_Discriminants (N);
end if;
End_Scope;
Set_Private_Dependents (T, New_Elmt_List);
Set_Is_Pure (T, F);
end Analyze_Incomplete_Type_Decl;
procedure Analyze_Itype_Reference (N : Node_Id) is
begin
pragma Assert (Is_Itype (Itype (N)));
null;
end Analyze_Itype_Reference;
procedure Analyze_Number_Declaration (N : Node_Id) is
Id : constant Entity_Id := Defining_Identifier (N);
E : constant Node_Id := Expression (N);
T : Entity_Id;
Index : Interp_Index;
It : Interp;
begin
Generate_Definition (Id);
Enter_Name (Id);
if Nkind (E) = N_Integer_Literal then
Set_Is_Static_Expression (E, True);
Set_Etype (E, Universal_Integer);
Set_Etype (Id, Universal_Integer);
Set_Ekind (Id, E_Named_Integer);
Set_Is_Frozen (Id, True);
return;
end if;
Set_Is_Pure (Id, Is_Pure (Current_Scope));
if E = Error then
Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0));
Set_Error_Posted (E);
end if;
Analyze (E);
if not Is_Overloaded (E) then
T := Etype (E);
else
T := Any_Type;
Get_First_Interp (E, Index, It);
while Present (It.Typ) loop
if (Is_Integer_Type (It.Typ)
or else Is_Real_Type (It.Typ))
and then (Scope (Base_Type (It.Typ))) = Standard_Standard
then
if T = Any_Type then
T := It.Typ;
elsif It.Typ = Universal_Real
or else It.Typ = Universal_Integer
then
T := It.Typ;
exit;
end if;
end if;
Get_Next_Interp (Index, It);
end loop;
end if;
if Is_Integer_Type (T) then
Resolve (E, T);
Set_Etype (Id, Universal_Integer);
Set_Ekind (Id, E_Named_Integer);
elsif Is_Real_Type (T) then
if T = Universal_Fixed then
declare
Loc : constant Source_Ptr := Sloc (N);
Conv : constant Node_Id := Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Universal_Real, Loc),
Expression => Relocate_Node (E));
begin
Rewrite (E, Conv);
Analyze (E);
end;
elsif T = Any_Fixed then
Error_Msg_N ("illegal context for mixed mode operation", E);
T := Universal_Real;
Set_Etype (E, T);
end if;
Resolve (E, T);
Set_Etype (Id, Universal_Real);
Set_Ekind (Id, E_Named_Real);
else
Wrong_Type (E, Any_Numeric);
Resolve (E, T);
Set_Etype (Id, T);
Set_Ekind (Id, E_Constant);
Set_Not_Source_Assigned (Id, True);
Set_Is_True_Constant (Id, True);
return;
end if;
if Nkind (E) = N_Integer_Literal
or else Nkind (E) = N_Real_Literal
then
Set_Etype (E, Etype (Id));
end if;
if not Is_OK_Static_Expression (E) then
Error_Msg_N ("non-static expression used in number declaration", E);
Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
Set_Etype (E, Any_Type);
end if;
end Analyze_Number_Declaration;
procedure Analyze_Object_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Identifier (N);
T : Entity_Id;
Act_T : Entity_Id;
E : Node_Id := Expression (N);
Prev_Entity : Entity_Id := Empty;
function Build_Default_Subtype return Entity_Id;
function Build_Default_Subtype return Entity_Id is
Act : Entity_Id;
Constraints : List_Id := New_List;
Decl : Node_Id;
Disc : Entity_Id;
begin
Disc := First_Discriminant (T);
if No (Discriminant_Default_Value (Disc)) then
return T; end if;
Act := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
while Present (Disc) loop
Append (
New_Copy_Tree (
Discriminant_Default_Value (Disc)), Constraints);
Next_Discriminant (Disc);
end loop;
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Act,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint
(Loc, Constraints)));
Insert_Before (N, Decl);
Analyze (Decl);
return Act;
end Build_Default_Subtype;
begin
if Constant_Present (N) then
Prev_Entity := Current_Entity_In_Scope (Id);
if Present (Prev_Entity)
and then Is_Overloadable (Prev_Entity)
and then Is_Inherited_Operation (Prev_Entity)
then
Prev_Entity := Empty;
end if;
end if;
if Present (Prev_Entity) then
Constant_Redeclaration (Id, N, T);
Generate_Reference (Prev_Entity, Id, 'c');
Set_Completion_Referenced (Id);
if Error_Posted (N) then
T := Find_Type_Of_Object (Object_Definition (N), N);
Set_Etype (Id, T);
Set_Ekind (Id, E_Variable);
return;
end if;
else
Generate_Definition (Id);
Enter_Name (Id);
T := Find_Type_Of_Object (Object_Definition (N), N);
if Error_Posted (Id) then
Set_Etype (Id, T);
Set_Ekind (Id, E_Variable);
return;
end if;
end if;
Set_Is_Pure (Id, Is_Pure (Current_Scope));
if Constant_Present (N)
and then No (E)
then
if not Is_Package (Current_Scope) then
Error_Msg_N
("invalid context for deferred constant declaration", N);
Set_Constant_Present (N, False);
elsif not Is_Private_Type (T) then
if Ada_83 and then Comes_From_Source (N) then
Error_Msg_N
("(Ada 83) deferred constant must be private type", N);
end if;
end if;
else
Check_Fully_Declared (T, N);
Freeze_Before (N, T);
end if;
if Nkind (Object_Definition (Declaration_Node (Id))) =
N_Constrained_Array_Definition
then
Set_Related_Array_Object (T, Id);
Set_Related_Array_Object (Base_Type (T), Id);
end if;
if Is_Protected_Type (T)
and then not Is_Library_Level_Entity (Id)
then
Check_Restriction (No_Local_Protected_Objects, Id);
if Has_Interrupt_Handler (T) then
Error_Msg_N
("interrupt object can only be declared at library level", Id);
end if;
end if;
Act_T := T;
if Present (E) and then E /= Error then
Analyze (E);
if not Assignment_OK (N) then
Check_Initialization (T, E);
end if;
Resolve (E, T);
if Is_Array_Type (T)
and then not Size_Known_At_Compile_Time (T)
and then Is_Library_Level_Entity (Id)
then
if T = Standard_String
and then Nkind (E) = N_String_Literal
then
null;
else
Check_Restriction
(No_Implicit_Heap_Allocations, Object_Definition (N));
end if;
end if;
if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
and then Is_Tagged_Type (T)
and then not Is_Class_Wide_Type (T)
then
Error_Msg_N ("dynamically tagged expression not allowed!", E);
end if;
Apply_Scalar_Range_Check (E, T);
Apply_Static_Length_Check (E, T);
end if;
if Is_Abstract (T) and then Comes_From_Source (N) then
Error_Msg_N ("type of object cannot be abstract",
Object_Definition (N));
if Is_CPP_Class (T) then
Error_Msg_NE ("\} may need a cpp_constructor",
Object_Definition (N), T);
end if;
elsif Is_Indefinite_Subtype (T) then
if Constant_Present (N) and then No (E) then
null;
elsif No (E) then
if No_Initialization (N) then
null;
elsif Is_Class_Wide_Type (T) then
Error_Msg_N
("initialization required in class-wide declaration ", N);
else
Error_Msg_N
("unconstrained subtype not allowed (need initialization)",
Object_Definition (N));
end if;
elsif E = Error then
Set_Expression (N, Empty);
E := Empty;
else
if not Constant_Present (N) then
if Ada_83
and then Comes_From_Source (Object_Definition (N))
then
Error_Msg_N
("(Ada 83) unconstrained variable not allowed",
Object_Definition (N));
end if;
end if;
if Is_Array_Type (T)
and then No_Initialization (N)
and then Nkind (Original_Node (E)) = N_Aggregate
then
Act_T := Etype (E);
else
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
end if;
Set_Is_Constr_Subt_For_U_Nominal (Act_T);
if Aliased_Present (N) then
Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
end if;
Freeze_Before (N, Act_T);
Freeze_Before (N, T);
end if;
elsif Is_Array_Type (T)
and then No_Initialization (N)
and then Nkind (Original_Node (E)) = N_Aggregate
then
if not Is_Entity_Name (Object_Definition (N)) then
Act_T := Etype (E);
if Aliased_Present (N) then
Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
end if;
end if;
if not Is_Constrained (T) then
null;
elsif Nkind (E) = N_Raise_Constraint_Error then
Set_Expression (N, E);
Set_No_Initialization (N, False);
elsif T = Etype (E) then
null;
elsif Nkind (E) = N_Aggregate
and then Present (Component_Associations (E))
and then Present (Choices (First (Component_Associations (E))))
and then Nkind (First
(Choices (First (Component_Associations (E))))) = N_Others_Choice
then
null;
else
Apply_Length_Check (E, T);
end if;
elsif (Is_Limited_Record (T)
or else Is_Concurrent_Type (T))
and then not Is_Constrained (T)
and then Has_Discriminants (T)
then
Act_T := Build_Default_Subtype;
Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
elsif not Is_Constrained (T)
and then Has_Discriminants (T)
and then Constant_Present (N)
and then Nkind (E) = N_Function_Call
then
Remove_Side_Effects (E);
end if;
if T = Standard_Wide_Character
or else Root_Type (T) = Standard_Wide_String
then
Check_Restriction (No_Wide_Characters, Object_Definition (N));
end if;
if Constant_Present (N) then
Set_Ekind (Id, E_Constant);
Set_Not_Source_Assigned (Id, True);
Set_Is_True_Constant (Id, True);
else
Set_Ekind (Id, E_Variable);
if Is_Shared_Passive (Current_Scope)
and then Is_Library_Level_Entity (Id)
and then Comes_From_Source (Id)
then
Set_Is_Shared_Passive (Id);
Check_Shared_Var (Id, T, N);
end if;
if Present (E) then
if not Is_Library_Level_Entity (Id) then
if False then
Set_Is_True_Constant (Id);
end if;
end if;
else
if Is_Access_Type (T)
or else not Is_Fully_Initialized_Type (T)
then
Set_Not_Source_Assigned (Id);
end if;
end if;
end if;
Init_Alignment (Id);
Init_Esize (Id);
if Aliased_Present (N) then
Set_Is_Aliased (Id);
if No (E)
and then Is_Record_Type (T)
and then not Is_Constrained (T)
and then Has_Discriminants (T)
then
Set_Actual_Subtype (Id, Build_Default_Subtype);
end if;
end if;
Set_Etype (Id, Act_T);
if Has_Controlled_Component (Etype (Id))
or else Is_Controlled (Etype (Id))
then
if not Is_Library_Level_Entity (Id) then
Check_Restriction (No_Nested_Finalization, N);
else
Validate_Controlled_Object (Id);
end if;
if Is_Controlled (Etype (Id))
and then Comes_From_Source (Id)
then
declare
BT : constant Entity_Id := Base_Type (Etype (Id));
Implicit_Call : Entity_Id;
function Is_Aggr (N : Node_Id) return Boolean;
function Is_Aggr (N : Node_Id) return Boolean is
begin
case Nkind (Original_Node (N)) is
when N_Aggregate | N_Extension_Aggregate =>
return True;
when N_Qualified_Expression |
N_Type_Conversion |
N_Unchecked_Type_Conversion =>
return Is_Aggr (Expression (Original_Node (N)));
when others =>
return False;
end case;
end Is_Aggr;
begin
if No (Underlying_Type (BT)) then
Implicit_Call := Empty;
elsif Is_Generic_Type (BT) then
Implicit_Call := Empty;
elsif Present (E) and then not Is_Aggr (E) then
Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
elsif No (E) and then not Constant_Present (N) then
Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
else
Implicit_Call := Empty;
end if;
end;
end if;
end if;
if Has_Task (Etype (Id)) then
if not Is_Library_Level_Entity (Id) then
Check_Restriction (No_Task_Hierarchy, N);
Check_Potentially_Blocking_Operation (N);
end if;
if Is_Task_Type (Etype (Id))
and then More_Ids (N)
then
declare
E : Entity_Id;
begin
E := First_Entity (Etype (Id));
while Present (E) loop
if Ekind (E) = E_Entry
and then Present (Get_Attribute_Definition_Clause
(E, Attribute_Address))
then
Error_Msg_N
("?more than one task with same entry address", N);
Error_Msg_N
("\?Program_Error will be raised at run time", N);
Insert_Action (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Duplicated_Entry_Address));
exit;
end if;
Next_Entity (E);
end loop;
end;
end if;
end if;
if Present (E)
and then Is_Entity_Name (E)
and then Ekind (Entity (E)) = E_Constant
and then Base_Type (Etype (E)) = Standard_String
then
declare
Val : constant Node_Id := Constant_Value (Entity (E));
begin
if Present (Val)
and then Nkind (Val) = N_String_Literal
then
Rewrite (E, New_Copy (Val));
end if;
end;
end if;
if Present (E)
and then Nkind (E) = N_Explicit_Dereference
and then Nkind (Original_Node (E)) = N_Function_Call
and then not Is_Library_Level_Entity (Id)
and then not Is_Constrained (T)
and then not Is_Aliased (Id)
and then not Is_Class_Wide_Type (T)
and then not Is_Controlled (T)
and then not Has_Controlled_Component (Base_Type (T))
and then Expander_Active
then
Rewrite (N,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
Subtype_Mark => New_Occurrence_Of
(Base_Type (Etype (Id)), Loc),
Name => E));
Set_Renamed_Object (Id, E);
end if;
if Present (Prev_Entity)
and then Is_Frozen (Prev_Entity)
and then not Error_Posted (Id)
then
Error_Msg_N ("full constant declaration appears too late", N);
end if;
Check_Eliminated (Id);
end Analyze_Object_Declaration;
procedure Analyze_Others_Choice (N : Node_Id) is
pragma Warnings (Off, N);
begin
null;
end Analyze_Others_Choice;
procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
T : Entity_Id := Defining_Identifier (N);
Indic : constant Node_Id := Subtype_Indication (N);
Parent_Type : Entity_Id;
Parent_Base : Entity_Id;
begin
Generate_Definition (T);
Enter_Name (T);
Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
Parent_Base := Base_Type (Parent_Type);
if Parent_Type = Any_Type
or else Etype (Parent_Type) = Any_Type
then
Set_Ekind (T, Ekind (Parent_Type));
Set_Etype (T, Any_Type);
return;
elsif not Is_Tagged_Type (Parent_Type) then
Error_Msg_N
("parent of type extension must be a tagged type ", Indic);
return;
elsif Ekind (Parent_Type) = E_Void
or else Ekind (Parent_Type) = E_Incomplete_Type
then
Error_Msg_N ("premature derivation of incomplete type", Indic);
return;
end if;
if Is_Class_Wide_Type (Parent_Type) then
Error_Msg_N
("parent of type extension must not be a class-wide type", Indic);
return;
end if;
if (not Is_Package (Current_Scope)
and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
or else In_Private_Part (Current_Scope)
then
Error_Msg_N ("invalid context for private extension", N);
end if;
Set_Is_Pure (T, Is_Pure (Current_Scope));
Set_Scope (T, Current_Scope);
Set_Ekind (T, E_Record_Type_With_Private);
Init_Size_Align (T);
Set_Etype (T, Parent_Base);
Set_Has_Task (T, Has_Task (Parent_Base));
Set_Convention (T, Convention (Parent_Type));
Set_First_Rep_Item (T, First_Rep_Item (Parent_Type));
Set_Is_First_Subtype (T);
Make_Class_Wide_Type (T);
Build_Derived_Record_Type (N, Parent_Type, T);
end Analyze_Private_Extension_Declaration;
procedure Analyze_Subtype_Declaration (N : Node_Id) is
Id : constant Entity_Id := Defining_Identifier (N);
T : Entity_Id;
R_Checks : Check_Result;
begin
Generate_Definition (Id);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
Init_Size_Align (Id);
if Present (Etype (Id))
and then (Is_Private_Type (Etype (Id))
or else Is_Task_Type (Etype (Id))
or else Is_Rewrite_Substitution (N))
then
null;
else
Enter_Name (Id);
end if;
T := Process_Subtype (Subtype_Indication (N), N, Id, 'P');
Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));
Set_Is_Volatile (Id, Is_Volatile (T));
Set_Is_Atomic (Id, Is_Atomic (T));
if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
Set_Etype (Id, Base_Type (T));
case Ekind (T) is
when Array_Kind =>
Set_Ekind (Id, E_Array_Subtype);
Set_First_Index (Id, First_Index (T));
Set_Is_Aliased (Id, Is_Aliased (T));
Set_Is_Constrained (Id, Is_Constrained (T));
when Decimal_Fixed_Point_Kind =>
Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype);
Set_Digits_Value (Id, Digits_Value (T));
Set_Delta_Value (Id, Delta_Value (T));
Set_Scale_Value (Id, Scale_Value (T));
Set_Small_Value (Id, Small_Value (T));
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Machine_Radix_10 (Id, Machine_Radix_10 (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_RM_Size (Id, RM_Size (T));
when Enumeration_Kind =>
Set_Ekind (Id, E_Enumeration_Subtype);
Set_First_Literal (Id, First_Literal (Base_Type (T)));
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Character_Type (Id, Is_Character_Type (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_RM_Size (Id, RM_Size (T));
when Ordinary_Fixed_Point_Kind =>
Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Small_Value (Id, Small_Value (T));
Set_Delta_Value (Id, Delta_Value (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_RM_Size (Id, RM_Size (T));
when Float_Kind =>
Set_Ekind (Id, E_Floating_Point_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Digits_Value (Id, Digits_Value (T));
Set_Is_Constrained (Id, Is_Constrained (T));
when Signed_Integer_Kind =>
Set_Ekind (Id, E_Signed_Integer_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_RM_Size (Id, RM_Size (T));
when Modular_Integer_Kind =>
Set_Ekind (Id, E_Modular_Integer_Subtype);
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_RM_Size (Id, RM_Size (T));
when Class_Wide_Kind =>
Set_Ekind (Id, E_Class_Wide_Subtype);
Set_First_Entity (Id, First_Entity (T));
Set_Last_Entity (Id, Last_Entity (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Cloned_Subtype (Id, T);
Set_Is_Tagged_Type (Id, True);
Set_Has_Unknown_Discriminants
(Id, True);
if Ekind (T) = E_Class_Wide_Subtype then
Set_Equivalent_Type (Id, Equivalent_Type (T));
end if;
when E_Record_Type | E_Record_Subtype =>
Set_Ekind (Id, E_Record_Subtype);
if Ekind (T) = E_Record_Subtype
and then Present (Cloned_Subtype (T))
then
Set_Cloned_Subtype (Id, Cloned_Subtype (T));
else
Set_Cloned_Subtype (Id, T);
end if;
Set_First_Entity (Id, First_Entity (T));
Set_Last_Entity (Id, Last_Entity (T));
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
if Has_Discriminants (T) then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (T));
Set_Girder_Constraint_From_Discriminant_Constraint (Id);
elsif Has_Unknown_Discriminants (Id) then
Set_Discriminant_Constraint (Id, No_Elist);
end if;
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
Set_Is_Abstract (Id, Is_Abstract (T));
Set_Primitive_Operations
(Id, Primitive_Operations (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
end if;
when Private_Kind =>
Set_Ekind (Id, Subtype_Kind (Ekind (T)));
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_First_Entity (Id, First_Entity (T));
Set_Last_Entity (Id, Last_Entity (T));
Set_Private_Dependents (Id, New_Elmt_List);
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
Set_Is_Abstract (Id, Is_Abstract (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
end if;
if Has_Discriminants (T) then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (T));
Set_Girder_Constraint_From_Discriminant_Constraint (Id);
elsif Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (Full_View (T)));
Set_Girder_Constraint_From_Discriminant_Constraint (Id);
end if;
Prepare_Private_Subtype_Completion (Id, N);
when Access_Kind =>
Set_Ekind (Id, E_Access_Subtype);
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Access_Constant
(Id, Is_Access_Constant (T));
Set_Directly_Designated_Type
(Id, Designated_Type (T));
if Comes_From_Source (Id)
and then In_Pure_Unit
and then not In_Subprogram_Task_Protected_Unit
then
Error_Msg_N
("named access types not allowed in pure unit", N);
end if;
when Concurrent_Kind =>
Set_Ekind (Id, Subtype_Kind (Ekind (T)));
Set_Corresponding_Record_Type (Id,
Corresponding_Record_Type (T));
Set_First_Entity (Id, First_Entity (T));
Set_First_Private_Entity (Id, First_Private_Entity (T));
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Last_Entity (Id, Last_Entity (T));
if Has_Discriminants (T) then
Set_Discriminant_Constraint (Id,
Discriminant_Constraint (T));
Set_Girder_Constraint_From_Discriminant_Constraint (Id);
end if;
when E_Incomplete_Type =>
Set_Etype (Id, Any_Type);
when others =>
raise Program_Error;
end case;
end if;
if Etype (Id) = Any_Type then
return;
end if;
Set_Size_Info (Id, T);
Set_First_Rep_Item (Id, First_Rep_Item (T));
T := Etype (Id);
Set_Is_Immediately_Visible (Id, True);
Set_Depends_On_Private (Id, Has_Private_Component (T));
if Present (Generic_Parent_Type (N))
and then
(Nkind
(Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
or else Nkind
(Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
/= N_Formal_Private_Type_Definition)
then
if Is_Tagged_Type (Id) then
if Is_Class_Wide_Type (Id) then
Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T));
else
Derive_Subprograms (Generic_Parent_Type (N), Id, T);
end if;
elsif Scope (Etype (Id)) /= Standard_Standard then
Derive_Subprograms (Generic_Parent_Type (N), Id);
end if;
end if;
if Is_Private_Type (T)
and then Present (Full_View (T))
then
Conditional_Delay (Id, Full_View (T));
elsif Ekind (Scope (Id)) /= E_Protected_Type
and then Present (Scope (Scope (Id))) and then Ekind (Scope (Scope (Id))) /= E_Protected_Type
then
Conditional_Delay (Id, T);
end if;
if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
if Is_Scalar_Type (Etype (Id))
and then Scalar_Range (Id) /=
Scalar_Range (Etype (Subtype_Mark
(Subtype_Indication (N))))
then
Apply_Range_Check
(Scalar_Range (Id),
Etype (Subtype_Mark (Subtype_Indication (N))));
elsif Is_Array_Type (Etype (Id))
and then Present (First_Index (Id))
then
if ((Nkind (First_Index (Id)) = N_Identifier
and then Ekind (Entity (First_Index (Id))) in Scalar_Kind)
or else Nkind (First_Index (Id)) = N_Subtype_Indication)
and then
Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range
then
declare
Target_Typ : Entity_Id :=
Etype
(First_Index
(Etype (Subtype_Mark (Subtype_Indication (N)))));
begin
R_Checks :=
Range_Check
(Scalar_Range (Etype (First_Index (Id))),
Target_Typ,
Etype (First_Index (Id)),
Defining_Identifier (N));
Insert_Range_Checks
(R_Checks,
N,
Target_Typ,
Sloc (Defining_Identifier (N)));
end;
end if;
end if;
end if;
Check_Eliminated (Id);
end Analyze_Subtype_Declaration;
procedure Analyze_Subtype_Indication (N : Node_Id) is
T : constant Entity_Id := Subtype_Mark (N);
R : constant Node_Id := Range_Expression (Constraint (N));
begin
Analyze (T);
if R /= Error then
Analyze (R);
Set_Etype (N, Etype (R));
else
Set_Error_Posted (R);
Set_Error_Posted (T);
end if;
end Analyze_Subtype_Indication;
procedure Analyze_Type_Declaration (N : Node_Id) is
Def : constant Node_Id := Type_Definition (N);
Def_Id : constant Entity_Id := Defining_Identifier (N);
T : Entity_Id;
Prev : Entity_Id;
begin
Prev := Find_Type_Name (N);
if Ekind (Prev) = E_Incomplete_Type then
T := Full_View (Prev);
else
T := Prev;
end if;
Set_Is_Pure (T, Is_Pure (Current_Scope));
Set_Is_First_Subtype (T, True);
case Nkind (Def) is
when N_Derived_Type_Definition =>
null;
when N_Record_Definition =>
null;
when others =>
if Present (Discriminant_Specifications (N)) then
Error_Msg_N
("elementary or array type cannot have discriminants",
Defining_Identifier
(First (Discriminant_Specifications (N))));
end if;
end case;
if not Analyzed (T) then
Set_Analyzed (T);
case Nkind (Def) is
when N_Access_To_Subprogram_Definition =>
Access_Subprogram_Declaration (T, Def);
if Is_Remote_Types (Current_Scope)
or else Is_Remote_Call_Interface (Current_Scope)
then
Validate_Remote_Access_To_Subprogram_Type (N);
Process_Remote_AST_Declaration (N);
end if;
Validate_Access_Type_Declaration (T, N);
when N_Access_To_Object_Definition =>
Access_Type_Declaration (T, Def);
Validate_Access_Type_Declaration (T, N);
if (Is_Remote_Call_Interface (Current_Scope)
or else Is_Remote_Types (Current_Scope))
and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
then
Add_RACW_Features (Def_Id);
end if;
when N_Array_Type_Definition =>
Array_Type_Declaration (T, Def);
when N_Derived_Type_Definition =>
Derived_Type_Declaration (T, N, T /= Def_Id);
when N_Enumeration_Type_Definition =>
Enumeration_Type_Declaration (T, Def);
when N_Floating_Point_Definition =>
Floating_Point_Type_Declaration (T, Def);
when N_Decimal_Fixed_Point_Definition =>
Decimal_Fixed_Point_Type_Declaration (T, Def);
when N_Ordinary_Fixed_Point_Definition =>
Ordinary_Fixed_Point_Type_Declaration (T, Def);
when N_Signed_Integer_Type_Definition =>
Signed_Integer_Type_Declaration (T, Def);
when N_Modular_Type_Definition =>
Modular_Type_Declaration (T, Def);
when N_Record_Definition =>
Record_Type_Declaration (T, N);
when others =>
raise Program_Error;
end case;
end if;
if Etype (T) = Any_Type then
return;
end if;
Set_Depends_On_Private (T, Has_Private_Component (T));
declare
B : constant Entity_Id := Base_Type (T);
begin
if B /= T then
Ensure_Freeze_Node (B);
Set_First_Subtype_Link (Freeze_Node (B), T);
end if;
if not From_With_Type (T) then
Set_Has_Delayed_Freeze (T);
end if;
end;
if T /= Def_Id and then Is_Private_Type (Def_Id) then
Process_Full_View (N, T, Def_Id);
Generate_Reference (T, T, 'c');
Set_Completion_Referenced (Def_Id);
elsif Ekind (Prev) = E_Incomplete_Type then
Process_Incomplete_Dependents (N, T, Prev);
Generate_Reference (Prev, Def_Id, 'c');
Set_Completion_Referenced (Def_Id);
else
Generate_Definition (Def_Id);
end if;
Check_Eliminated (Def_Id);
end Analyze_Type_Declaration;
procedure Analyze_Variant_Part (N : Node_Id) is
procedure Non_Static_Choice_Error (Choice : Node_Id);
procedure Process_Declarations (Variant : Node_Id);
package Variant_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Variants,
Get_Choices => Discrete_Choices,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Declarations);
use Variant_Choices_Processing;
procedure Non_Static_Choice_Error (Choice : Node_Id) is
begin
Error_Msg_N ("choice given in variant part is not static", Choice);
end Non_Static_Choice_Error;
procedure Process_Declarations (Variant : Node_Id) is
begin
if not Null_Present (Component_List (Variant)) then
Analyze_Declarations (Component_Items (Component_List (Variant)));
if Present (Variant_Part (Component_List (Variant))) then
Analyze (Variant_Part (Component_List (Variant)));
end if;
end if;
end Process_Declarations;
Others_Choice : Node_Id;
Discr_Name : Node_Id;
Discr_Type : Entity_Id;
Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
Last_Choice : Nat;
Dont_Care : Boolean;
Others_Present : Boolean := False;
begin
Discr_Name := Name (N);
Analyze (Discr_Name);
if Ekind (Entity (Discr_Name)) /= E_Discriminant then
Error_Msg_N ("invalid discriminant name in variant part", Discr_Name);
end if;
Discr_Type := Etype (Entity (Discr_Name));
if not Is_Discrete_Type (Discr_Type) then
Error_Msg_N
("discriminant in a variant part must be of a discrete type",
Name (N));
return;
end if;
Analyze_Choices
(N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
if Others_Present then
Others_Choice := First (Discrete_Choices (Last (Variants (N))));
Expand_Others_Choice
(Case_Table (1 .. Last_Choice), Others_Choice, Discr_Type);
end if;
end Analyze_Variant_Part;
procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
Component_Def : constant Node_Id := Subtype_Indication (Def);
Element_Type : Entity_Id;
Implicit_Base : Entity_Id;
Index : Node_Id;
Related_Id : Entity_Id := Empty;
Nb_Index : Nat;
P : constant Node_Id := Parent (Def);
Priv : Entity_Id;
begin
if Nkind (Def) = N_Constrained_Array_Definition then
Index := First (Discrete_Subtype_Definitions (Def));
if No (T) then
Related_Id := Defining_Identifier (P);
else
Related_Id := T;
end if;
else
Index := First (Subtype_Marks (Def));
end if;
Nb_Index := 1;
while Present (Index) loop
Analyze (Index);
Make_Index (Index, P, Related_Id, Nb_Index);
Next_Index (Index);
Nb_Index := Nb_Index + 1;
end loop;
Element_Type := Process_Subtype (Component_Def, P, Related_Id, 'C');
if No (T) then
T := Create_Itype (E_Void, P, Related_Id, 'T');
end if;
if Nkind (Def) = N_Constrained_Array_Definition then
Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B');
Init_Size_Align (Implicit_Base);
Set_Etype (Implicit_Base, Implicit_Base);
Set_Scope (Implicit_Base, Current_Scope);
Set_Has_Delayed_Freeze (Implicit_Base);
Set_Ekind (T, E_Array_Subtype);
Init_Size_Align (T);
Set_Etype (T, Implicit_Base);
Set_Scope (T, Current_Scope);
Set_Is_Constrained (T, True);
Set_First_Index (T, First (Discrete_Subtype_Definitions (Def)));
Set_Has_Delayed_Freeze (T);
Set_First_Index (Implicit_Base, First_Index (T));
Set_Component_Type (Implicit_Base, Element_Type);
Set_Has_Task (Implicit_Base, Has_Task (Element_Type));
Set_Component_Size (Implicit_Base, Uint_0);
Set_Has_Controlled_Component
(Implicit_Base, Has_Controlled_Component
(Element_Type)
or else
Is_Controlled (Element_Type));
Set_Finalize_Storage_Only
(Implicit_Base, Finalize_Storage_Only
(Element_Type));
else
Set_Ekind (T, E_Array_Type);
Init_Size_Align (T);
Set_Etype (T, T);
Set_Scope (T, Current_Scope);
Set_Component_Size (T, Uint_0);
Set_Is_Constrained (T, False);
Set_First_Index (T, First (Subtype_Marks (Def)));
Set_Has_Delayed_Freeze (T, True);
Set_Has_Task (T, Has_Task (Element_Type));
Set_Has_Controlled_Component (T, Has_Controlled_Component
(Element_Type)
or else
Is_Controlled (Element_Type));
Set_Finalize_Storage_Only (T, Finalize_Storage_Only
(Element_Type));
end if;
Set_Component_Type (Base_Type (T), Element_Type);
if Aliased_Present (Def) then
Set_Has_Aliased_Components (Etype (T));
end if;
Priv := Private_Component (Element_Type);
if Present (Priv) then
if Priv = Any_Type then
Set_Component_Type (Etype (T), Any_Type);
elsif Scope (Priv) = Current_Scope then
null;
elsif Is_Limited_Type (Priv) then
Set_Is_Limited_Composite (Etype (T));
Set_Is_Limited_Composite (T);
else
Set_Is_Private_Composite (Etype (T));
Set_Is_Private_Composite (T);
end if;
end if;
if Number_Dimensions (T) = 1
and then not Is_Packed_Array_Type (T)
then
New_Binary_Operator (Name_Op_Concat, T);
end if;
if Is_Indefinite_Subtype (Element_Type) then
Error_Msg_N
("unconstrained element type in array declaration ",
Component_Def);
elsif Is_Abstract (Element_Type) then
Error_Msg_N ("The type of a component cannot be abstract ",
Component_Def);
end if;
end Array_Type_Declaration;
procedure Build_Derived_Access_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
S : constant Node_Id := Subtype_Indication (Type_Definition (N));
Desig_Type : Entity_Id;
Discr : Entity_Id;
Discr_Con_Elist : Elist_Id;
Discr_Con_El : Elmt_Id;
Subt : Entity_Id;
begin
Set_Directly_Designated_Type (Derived_Type,
Designated_Type (Parent_Type));
Subt := Process_Subtype (S, N);
if Nkind (S) /= N_Subtype_Indication
and then Subt /= Base_Type (Subt)
then
Set_Ekind (Derived_Type, E_Access_Subtype);
end if;
if Ekind (Derived_Type) = E_Access_Subtype then
declare
Pbase : constant Entity_Id := Base_Type (Parent_Type);
Ibase : constant Entity_Id :=
Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
Svg_Chars : constant Name_Id := Chars (Ibase);
Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
begin
Copy_Node (Pbase, Ibase);
Set_Chars (Ibase, Svg_Chars);
Set_Next_Entity (Ibase, Svg_Next_E);
Set_Sloc (Ibase, Sloc (Derived_Type));
Set_Scope (Ibase, Scope (Derived_Type));
Set_Freeze_Node (Ibase, Empty);
Set_Is_Frozen (Ibase, False);
Set_Comes_From_Source (Ibase, False);
Set_Is_First_Subtype (Ibase, False);
Set_Etype (Ibase, Pbase);
Set_Etype (Derived_Type, Ibase);
end;
end if;
Set_Directly_Designated_Type
(Derived_Type, Designated_Type (Subt));
Set_Is_Constrained (Derived_Type, Is_Constrained (Subt));
Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type));
Set_Size_Info (Derived_Type, Parent_Type);
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
Set_Depends_On_Private (Derived_Type,
Has_Private_Component (Derived_Type));
Conditional_Delay (Derived_Type, Subt);
Desig_Type := Designated_Type (Derived_Type);
if Is_Composite_Type (Desig_Type)
and then (not Is_Array_Type (Desig_Type))
and then Has_Discriminants (Desig_Type)
and then Base_Type (Desig_Type) /= Desig_Type
then
Discr_Con_Elist := Discriminant_Constraint (Desig_Type);
Discr_Con_El := First_Elmt (Discr_Con_Elist);
Discr := First_Discriminant (Base_Type (Desig_Type));
while Present (Discr_Con_El) loop
Apply_Range_Check (Node (Discr_Con_El), Etype (Discr));
Next_Elmt (Discr_Con_El);
Next_Discriminant (Discr);
end loop;
end if;
end Build_Derived_Access_Type;
procedure Build_Derived_Array_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Tdef : constant Node_Id := Type_Definition (N);
Indic : constant Node_Id := Subtype_Indication (Tdef);
Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
Implicit_Base : Entity_Id;
New_Indic : Node_Id;
procedure Make_Implicit_Base;
procedure Make_Implicit_Base is
begin
Implicit_Base :=
Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
Set_Ekind (Implicit_Base, Ekind (Parent_Base));
Set_Etype (Implicit_Base, Parent_Base);
Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base);
Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
Set_Has_Delayed_Freeze (Implicit_Base, True);
end Make_Implicit_Base;
begin
if not Is_Constrained (Parent_Type) then
if Nkind (Indic) /= N_Subtype_Indication then
Set_Ekind (Derived_Type, E_Array_Type);
Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type);
Set_Has_Delayed_Freeze (Derived_Type, True);
else
Make_Implicit_Base;
Set_Etype (Derived_Type, Implicit_Base);
New_Indic :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Derived_Type,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (Implicit_Base, Loc),
Constraint => Constraint (Indic)));
Rewrite (N, New_Indic);
Analyze (N);
end if;
else
if Nkind (Indic) /= N_Subtype_Indication then
Make_Implicit_Base;
Set_Ekind (Derived_Type, Ekind (Parent_Type));
Set_Etype (Derived_Type, Implicit_Base);
Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
else
Error_Msg_N ("illegal constraint on constrained type", Indic);
end if;
end if;
if Number_Dimensions (Parent_Type) = 1
and then not Is_Limited_Type (Parent_Type)
and then not Is_Derived_Type (Parent_Type)
and then not Is_Package (Scope (Base_Type (Parent_Type)))
then
New_Binary_Operator (Name_Op_Concat, Derived_Type);
end if;
end Build_Derived_Array_Type;
procedure Build_Derived_Concurrent_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
D_Constraint : Node_Id;
Disc_Spec : Node_Id;
Old_Disc : Entity_Id;
New_Disc : Entity_Id;
Constraint_Present : constant Boolean :=
Nkind (Subtype_Indication (Type_Definition (N)))
= N_Subtype_Indication;
begin
Set_Girder_Constraint (Derived_Type, No_Elist);
if Is_Task_Type (Parent_Type) then
Set_Storage_Size_Variable (Derived_Type,
Storage_Size_Variable (Parent_Type));
end if;
if Present (Discriminant_Specifications (N)) then
New_Scope (Derived_Type);
Check_Or_Process_Discriminants (N, Derived_Type);
End_Scope;
elsif Constraint_Present then
declare
Loc : constant Source_Ptr := Sloc (N);
Anon : Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Derived_Type), 'T'));
Decl : Node_Id;
begin
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Anon,
Subtype_Indication =>
New_Copy_Tree (Subtype_Indication (Type_Definition (N))));
Insert_Before (N, Decl);
Rewrite (Subtype_Indication (Type_Definition (N)),
New_Occurrence_Of (Anon, Loc));
Analyze (Decl);
Set_Analyzed (Derived_Type, False);
Analyze (N);
return;
end;
end if;
Set_Has_Discriminants
(Derived_Type, Has_Discriminants (Parent_Type));
Set_Corresponding_Record_Type
(Derived_Type, Corresponding_Record_Type (Parent_Type));
if Constraint_Present then
if not Has_Discriminants (Parent_Type) then
Error_Msg_N ("untagged parent must have discriminants", N);
elsif Present (Discriminant_Specifications (N)) then
Old_Disc := First_Discriminant (Parent_Type);
New_Disc := First_Discriminant (Derived_Type);
Disc_Spec := First (Discriminant_Specifications (N));
D_Constraint :=
First
(Constraints
(Constraint (Subtype_Indication (Type_Definition (N)))));
while Present (Old_Disc) and then Present (Disc_Spec) loop
if Nkind (Discriminant_Type (Disc_Spec)) /=
N_Access_Definition
then
Analyze (Discriminant_Type (Disc_Spec));
if not Subtypes_Statically_Compatible (
Etype (Discriminant_Type (Disc_Spec)),
Etype (Old_Disc))
then
Error_Msg_N
("not statically compatible with parent discriminant",
Discriminant_Type (Disc_Spec));
end if;
end if;
if Nkind (D_Constraint) = N_Identifier
and then Chars (D_Constraint) /=
Chars (Defining_Identifier (Disc_Spec))
then
Error_Msg_N ("new discriminants must constrain old ones",
D_Constraint);
else
Set_Corresponding_Discriminant (New_Disc, Old_Disc);
end if;
Next_Discriminant (Old_Disc);
Next_Discriminant (New_Disc);
Next (Disc_Spec);
end loop;
if Present (Old_Disc) or else Present (Disc_Spec) then
Error_Msg_N ("discriminant mismatch in derivation", N);
end if;
end if;
elsif Present (Discriminant_Specifications (N)) then
Error_Msg_N
("missing discriminant constraint in untagged derivation",
N);
end if;
if Present (Discriminant_Specifications (N)) then
Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop
if No (Next_Entity (Old_Disc))
or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
then
Set_Next_Entity (Last_Entity (Derived_Type),
Next_Entity (Old_Disc));
exit;
end if;
Next_Discriminant (Old_Disc);
end loop;
else
Set_First_Entity (Derived_Type, First_Entity (Parent_Type));
if Has_Discriminants (Parent_Type) then
Set_Discriminant_Constraint (
Derived_Type, Discriminant_Constraint (Parent_Type));
end if;
end if;
Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type));
Set_Has_Completion (Derived_Type);
end Build_Derived_Concurrent_Type;
procedure Build_Derived_Enumeration_Type
(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);
Implicit_Base : Entity_Id;
Literal : Entity_Id;
New_Lit : Entity_Id;
Literals_List : List_Id;
Type_Decl : Node_Id;
Hi, Lo : Node_Id;
Rang_Expr : Node_Id;
begin
if Root_Type (Parent_Type) = Standard_Character
or else Root_Type (Parent_Type) = Standard_Wide_Character
then
Derived_Standard_Character (N, Parent_Type, Derived_Type);
elsif Is_Generic_Type (Root_Type (Parent_Type)) then
declare
Lo : Node_Id;
Hi : Node_Id;
begin
Lo :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix => New_Reference_To (Derived_Type, Loc));
Set_Etype (Lo, Derived_Type);
Hi :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix => New_Reference_To (Derived_Type, Loc));
Set_Etype (Hi, Derived_Type);
Set_Scalar_Range (Derived_Type,
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi));
end;
else
if Nkind (Indic) = N_Subtype_Indication
and then Nkind (Range_Expression (Constraint (Indic))) = N_Range
then
Analyze (Low_Bound (Range_Expression (Constraint (Indic))));
Analyze (High_Bound (Range_Expression (Constraint (Indic))));
end if;
Literal := First_Literal (Parent_Type);
Literals_List := New_List;
while Present (Literal)
and then Ekind (Literal) = E_Enumeration_Literal
loop
if Nkind (Literal) = N_Defining_Character_Literal then
New_Lit :=
Make_Defining_Character_Literal (Loc, Chars (Literal));
else
New_Lit := Make_Defining_Identifier (Loc, Chars (Literal));
end if;
Set_Ekind (New_Lit, E_Enumeration_Literal);
Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal));
Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal));
Set_Enumeration_Rep_Expr (New_Lit, Empty);
Set_Alias (New_Lit, Literal);
Set_Is_Known_Valid (New_Lit, True);
Append (New_Lit, Literals_List);
Next_Literal (Literal);
end loop;
Implicit_Base :=
Make_Defining_Identifier (Sloc (Derived_Type),
New_External_Name (Chars (Derived_Type), 'B'));
Set_Ekind (Derived_Type, E_Enumeration_Subtype);
Set_Etype (Derived_Type, Implicit_Base);
Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Implicit_Base,
Discriminant_Specifications => No_List,
Type_Definition =>
Make_Enumeration_Type_Definition (Loc, Literals_List));
Mark_Rewrite_Insertion (Type_Decl);
Insert_Before (N, Type_Decl);
Analyze (Type_Decl);
Set_Etype (Implicit_Base, Parent_Type);
Set_Size_Info (Implicit_Base, Parent_Type);
Set_RM_Size (Implicit_Base, RM_Size (Parent_Type));
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type));
Set_Has_Non_Standard_Rep
(Implicit_Base, Has_Non_Standard_Rep
(Parent_Type));
Set_Has_Delayed_Freeze (Implicit_Base);
if Nkind (Indic) = N_Subtype_Indication then
declare
R : constant Node_Id :=
Range_Expression (Constraint (Indic));
begin
if Nkind (R) = N_Range then
Hi := Build_Scalar_Bound
(High_Bound (R), Parent_Type, Implicit_Base);
Lo := Build_Scalar_Bound
(Low_Bound (R), Parent_Type, Implicit_Base);
else
Analyze (Prefix (R));
Hi :=
Convert_To (Implicit_Base,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix =>
New_Occurrence_Of (Entity (Prefix (R)), Loc)));
Lo :=
Convert_To (Implicit_Base,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix =>
New_Occurrence_Of (Entity (Prefix (R)), Loc)));
end if;
end;
else
Hi :=
Build_Scalar_Bound
(Type_High_Bound (Parent_Type),
Parent_Type, Implicit_Base);
Lo :=
Build_Scalar_Bound
(Type_Low_Bound (Parent_Type),
Parent_Type, Implicit_Base);
end if;
Rang_Expr :=
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi);
if Nkind (Indic) /= N_Subtype_Indication then
Set_Must_Not_Freeze (Lo);
Set_Must_Not_Freeze (Hi);
Set_Must_Not_Freeze (Rang_Expr);
end if;
Rewrite (N,
Make_Subtype_Declaration (Loc,
Defining_Identifier => Derived_Type,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc),
Constraint =>
Make_Range_Constraint (Loc,
Range_Expression => Rang_Expr))));
Analyze (N);
if Einfo.Discard_Names (First_Subtype (Parent_Type)) then
Set_Discard_Names (Derived_Type);
end if;
if Nkind (Indic) = N_Subtype_Indication then
Apply_Range_Check (Range_Expression (Constraint (Indic)),
Parent_Type,
Source_Typ => Entity (Subtype_Mark (Indic)));
end if;
end if;
end Build_Derived_Enumeration_Type;
procedure Build_Derived_Numeric_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Tdef : constant Node_Id := Type_Definition (N);
Indic : constant Node_Id := Subtype_Indication (Tdef);
Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
No_Constraint : constant Boolean := Nkind (Indic) /=
N_Subtype_Indication;
Implicit_Base : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
T : Entity_Id;
begin
T := Process_Subtype (Indic, N);
Implicit_Base :=
Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B');
Set_Etype (Implicit_Base, Parent_Base);
Set_Ekind (Implicit_Base, Ekind (Parent_Base));
Set_Size_Info (Implicit_Base, Parent_Base);
Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
Set_Parent (Implicit_Base, Parent (Derived_Type));
if Is_Discrete_Or_Fixed_Point_Type (Parent_Base) then
Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
end if;
Set_Has_Delayed_Freeze (Implicit_Base);
Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base));
Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
Set_Scalar_Range (Implicit_Base,
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi));
if Has_Infinities (Parent_Base) then
Set_Includes_Infinities (Scalar_Range (Implicit_Base));
end if;
Set_Etype (Derived_Type, Implicit_Base);
if No_Constraint then
Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type)));
end if;
if No_Constraint
or else not Has_Range_Constraint (Indic)
then
Set_Scalar_Range (Derived_Type,
Make_Range (Loc,
Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)),
High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type))));
Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
if Has_Infinities (Parent_Type) then
Set_Includes_Infinities (Scalar_Range (Derived_Type));
end if;
end if;
if Is_Modular_Integer_Type (Parent_Type) then
Set_Modulus (Implicit_Base, Modulus (Parent_Base));
Set_Non_Binary_Modulus
(Implicit_Base, Non_Binary_Modulus (Parent_Base));
elsif Is_Floating_Point_Type (Parent_Type) then
Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
Set_Vax_Float (Implicit_Base, Vax_Float (Parent_Base));
if No_Constraint then
Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type));
end if;
elsif Is_Fixed_Point_Type (Parent_Type) then
Set_Small_Value (Derived_Type, Small_Value (Parent_Base));
Set_Small_Value (Implicit_Base, Small_Value (Parent_Base));
Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base));
if No_Constraint then
Set_Delta_Value (Derived_Type, Delta_Value (Parent_Type));
end if;
if Is_Decimal_Fixed_Point_Type (Parent_Type) then
Set_Scale_Value (Derived_Type, Scale_Value (Parent_Base));
Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base));
Set_Machine_Radix_10
(Derived_Type, Machine_Radix_10 (Parent_Base));
Set_Machine_Radix_10
(Implicit_Base, Machine_Radix_10 (Parent_Base));
Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
if No_Constraint then
Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base));
else
null;
end if;
end if;
end if;
Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
if Is_Fixed_Point_Type (Parent_Type) then
Conditional_Delay (Implicit_Base, Parent_Type);
else
Freeze_Before (N, Implicit_Base);
end if;
end Build_Derived_Numeric_Type;
procedure Build_Derived_Private_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Is_Completion : Boolean;
Derive_Subps : Boolean := True)
is
Der_Base : Entity_Id;
Discr : Entity_Id;
Full_Decl : Node_Id := Empty;
Full_Der : Entity_Id;
Full_P : Entity_Id;
Last_Discr : Entity_Id;
Par_Scope : constant Entity_Id := Scope (Base_Type (Parent_Type));
Swapped : Boolean := False;
procedure Copy_And_Build;
procedure Copy_And_Build is
Full_N : Node_Id;
begin
if Ekind (Parent_Type) in Record_Kind
or else (Ekind (Parent_Type) in Enumeration_Kind
and then Root_Type (Parent_Type) /= Standard_Character
and then Root_Type (Parent_Type) /= Standard_Wide_Character
and then not Is_Generic_Type (Root_Type (Parent_Type)))
then
Full_N := New_Copy_Tree (N);
Insert_After (N, Full_N);
Build_Derived_Type (
Full_N, Parent_Type, Full_Der, True, Derive_Subps => False);
else
Build_Derived_Type (
N, Parent_Type, Full_Der, True, Derive_Subps => False);
end if;
end Copy_And_Build;
begin
if Is_Tagged_Type (Parent_Type) then
Build_Derived_Record_Type
(N, Parent_Type, Derived_Type, Derive_Subps);
return;
elsif Has_Discriminants (Parent_Type) then
if Present (Full_View (Parent_Type)) then
if not Is_Completion then
Full_Decl := New_Copy_Tree (N);
Full_Der := New_Copy (Derived_Type);
Insert_After (N, Full_Decl);
else
if No (Discriminant_Specifications (N)) then
if Nkind (Subtype_Indication (Type_Definition (N)))
= N_Subtype_Indication
then
Build_Underlying_Full_View (N, Derived_Type, Parent_Type);
elsif Is_Constrained (Full_View (Parent_Type)) then
Set_Underlying_Full_View (Derived_Type,
Full_View (Parent_Type));
end if;
else
null;
end if;
end if;
end if;
Build_Derived_Record_Type
(N, Parent_Type, Derived_Type, Derive_Subps);
if Present (Full_View (Parent_Type))
and then not Is_Completion
then
if not In_Open_Scopes (Par_Scope)
or else not In_Same_Source_Unit (N, Parent_Type)
then
Install_Private_Declarations (Par_Scope);
Install_Visible_Declarations (Par_Scope);
Swapped := True;
end if;
Build_Derived_Record_Type
(Full_Decl, Parent_Type, Full_Der, False);
if Swapped then
Uninstall_Declarations (Par_Scope);
if In_Open_Scopes (Par_Scope) then
Install_Visible_Declarations (Par_Scope);
end if;
end if;
Der_Base := Base_Type (Derived_Type);
Set_Full_View (Derived_Type, Full_Der);
Set_Full_View (Der_Base, Base_Type (Full_Der));
Discr := First_Discriminant (Base_Type (Full_Der));
Set_First_Entity (Der_Base, Discr);
loop
Last_Discr := Discr;
Next_Discriminant (Discr);
exit when No (Discr);
end loop;
Set_Last_Entity (Der_Base, Last_Discr);
Set_First_Entity (Derived_Type, First_Entity (Der_Base));
Set_Last_Entity (Derived_Type, Last_Entity (Der_Base));
else
null;
end if;
elsif Present (Full_View (Parent_Type))
and then Has_Discriminants (Full_View (Parent_Type))
then
if Has_Unknown_Discriminants (Parent_Type)
and then Nkind (Subtype_Indication (Type_Definition (N)))
= N_Subtype_Indication
then
Error_Msg_N
("cannot constrain type with unknown discriminants",
Subtype_Indication (Type_Definition (N)));
return;
end if;
if not Is_Private_Type (Full_View (Parent_Type)) then
Full_Der := Make_Defining_Identifier (Sloc (Derived_Type),
Chars (Derived_Type));
Set_Is_Itype (Full_Der);
Set_Has_Private_Declaration (Full_Der);
Set_Has_Private_Declaration (Derived_Type);
Set_Associated_Node_For_Itype (Full_Der, N);
Set_Parent (Full_Der, Parent (Derived_Type));
Set_Full_View (Derived_Type, Full_Der);
Full_P := Full_View (Parent_Type);
Exchange_Declarations (Parent_Type);
Copy_And_Build;
Exchange_Declarations (Full_P);
else
Build_Derived_Record_Type
(N, Full_View (Parent_Type), Derived_Type,
Derive_Subps => False);
end if;
Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
if Derive_Subps then
Derive_Subprograms (Parent_Type, Derived_Type);
end if;
else
if Nkind (Subtype_Indication (Type_Definition (N)))
= N_Subtype_Indication
then
Error_Msg_N
("illegal constraint on type without discriminants", N);
end if;
if Present (Discriminant_Specifications (N))
and then Present (Full_View (Parent_Type))
and then not Is_Tagged_Type (Full_View (Parent_Type))
then
Error_Msg_N
("cannot add discriminants to untagged type", N);
end if;
Set_Girder_Constraint (Derived_Type, No_Elist);
Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
Set_Has_Controlled_Component
(Derived_Type, Has_Controlled_Component
(Parent_Type));
if not Is_Controlled (Parent_Type) then
Set_Finalize_Storage_Only
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
end if;
if Present (Full_View (Parent_Type))
and then not Is_Tagged_Type (Full_View (Parent_Type))
and then not Is_Completion
then
Full_Der := Make_Defining_Identifier (Sloc (Derived_Type),
Chars (Derived_Type));
Set_Is_Itype (Full_Der);
Set_Has_Private_Declaration (Full_Der);
Set_Has_Private_Declaration (Derived_Type);
Set_Associated_Node_For_Itype (Full_Der, N);
Set_Parent (Full_Der, Parent (Derived_Type));
Set_Full_View (Derived_Type, Full_Der);
if not In_Open_Scopes (Par_Scope) then
Install_Private_Declarations (Par_Scope);
Install_Visible_Declarations (Par_Scope);
Copy_And_Build;
Uninstall_Declarations (Par_Scope);
elsif not In_Same_Source_Unit (N, Parent_Type) then
Full_P := Full_View (Parent_Type);
Exchange_Declarations (Parent_Type);
Copy_And_Build;
Exchange_Declarations (Full_P);
else
Copy_And_Build;
end if;
Set_Scope (Full_Der, Current_Scope);
Set_Is_First_Subtype (Full_Der,
Is_First_Subtype (Derived_Type));
Set_Has_Size_Clause (Full_Der, False);
Set_Has_Alignment_Clause (Full_Der, False);
Set_Next_Entity (Full_Der, Empty);
Set_Has_Delayed_Freeze (Full_Der);
Set_Is_Frozen (Full_Der, False);
Set_Freeze_Node (Full_Der, Empty);
Set_Depends_On_Private (Full_Der,
Has_Private_Component (Full_Der));
Set_Public_Status (Full_Der);
end if;
end if;
Set_Has_Unknown_Discriminants (Derived_Type,
Has_Unknown_Discriminants (Parent_Type));
if Is_Private_Type (Derived_Type) then
Set_Private_Dependents (Derived_Type, New_Elmt_List);
end if;
if Is_Private_Type (Parent_Type)
and then Base_Type (Parent_Type) = Parent_Type
and then In_Open_Scopes (Scope (Parent_Type))
then
Append_Elmt (Derived_Type, Private_Dependents (Parent_Type));
if Is_Child_Unit (Scope (Current_Scope))
and then Is_Completion
and then In_Private_Part (Current_Scope)
and then Scope (Parent_Type) /= Current_Scope
then
declare
IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
begin
Full_Der :=
Make_Defining_Identifier (Sloc (Derived_Type),
Chars (Derived_Type));
Set_Is_Itype (Full_Der);
Set_Itype (IR, Full_Der);
Insert_After (N, IR);
Append_Entity (Full_Der, Scope (Derived_Type));
Set_Has_Private_Declaration (Full_Der);
Set_Has_Private_Declaration (Derived_Type);
Set_Associated_Node_For_Itype (Full_Der, N);
Set_Parent (Full_Der, Parent (Derived_Type));
Full_P := Full_View (Parent_Type);
Exchange_Declarations (Parent_Type);
Copy_And_Build;
Exchange_Declarations (Full_P);
Set_Underlying_Full_View (Derived_Type, Full_Der);
end;
end if;
end if;
end Build_Derived_Private_Type;
procedure Build_Derived_Record_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Derive_Subps : Boolean := True)
is
Loc : constant Source_Ptr := Sloc (N);
Parent_Base : Entity_Id;
Type_Def : Node_Id;
Indic : Node_Id;
Discrim : Entity_Id;
Last_Discrim : Entity_Id;
Constrs : Elist_Id;
Discs : Elist_Id := New_Elmt_List;
Assoc_List : Elist_Id;
New_Discrs : Elist_Id;
New_Base : Entity_Id;
New_Decl : Node_Id;
New_Indic : Node_Id;
Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type);
Discriminant_Specs : constant Boolean :=
Present (Discriminant_Specifications (N));
Private_Extension : constant Boolean :=
(Nkind (N) = N_Private_Extension_Declaration);
Constraint_Present : Boolean;
Inherit_Discrims : Boolean := False;
Save_Etype : Entity_Id;
Save_Discr_Constr : Elist_Id;
Save_Next_Entity : Entity_Id;
begin
if Ekind (Parent_Type) = E_Record_Type_With_Private
and then Present (Full_View (Parent_Type))
and then Has_Discriminants (Parent_Type)
then
Parent_Base := Base_Type (Full_View (Parent_Type));
else
Parent_Base := Base_Type (Parent_Type);
end if;
if Is_Tagged then
Init_Size_Align (Derived_Type);
end if;
if Private_Extension then
Type_Def := N;
Set_Ekind (Derived_Type, E_Record_Type_With_Private);
else
Type_Def := Type_Definition (N);
if Present (Record_Extension_Part (Type_Def)) then
Set_Ekind (Derived_Type, E_Record_Type);
else
Set_Ekind (Derived_Type, Ekind (Parent_Base));
end if;
end if;
Indic := Subtype_Indication (Type_Def);
Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
if Constraint_Present then
if not Has_Discriminants (Parent_Base) then
Error_Msg_N
("invalid constraint: type has no discriminant",
Constraint (Indic));
Constraint_Present := False;
Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
elsif Is_Constrained (Parent_Type) then
Error_Msg_N
("invalid constraint: parent type is already constrained",
Constraint (Indic));
Constraint_Present := False;
Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic)));
end if;
end if;
if not Private_Extension
and then Has_Discriminants (Parent_Type)
and then not Discriminant_Specs
and then (Is_Constrained (Parent_Type) or else Constraint_Present)
then
if Constraint_Present then
New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic);
if Has_Discriminants (Derived_Type)
and then Has_Private_Declaration (Derived_Type)
and then Present (Discriminant_Constraint (Derived_Type))
then
declare
C1, C2 : Elmt_Id;
begin
C1 := First_Elmt (New_Discrs);
C2 := First_Elmt (Discriminant_Constraint (Derived_Type));
while Present (C1) and then Present (C2) loop
if not
Fully_Conformant_Expressions (Node (C1), Node (C2))
then
Error_Msg_N (
"constraint not conformant to previous declaration",
Node (C1));
end if;
Next_Elmt (C1);
Next_Elmt (C2);
end loop;
end;
end if;
end if;
New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B');
New_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => New_Base,
Type_Definition =>
Make_Derived_Type_Definition (Loc,
Abstract_Present => Abstract_Present (Type_Def),
Subtype_Indication =>
New_Occurrence_Of (Parent_Base, Loc),
Record_Extension_Part =>
Relocate_Node (Record_Extension_Part (Type_Def))));
Set_Parent (New_Decl, Parent (N));
Mark_Rewrite_Insertion (New_Decl);
Insert_Before (N, New_Decl);
Build_Derived_Type
(New_Decl, Parent_Base, New_Base,
Is_Completion => True, Derive_Subps => False);
Set_Analyzed (New_Decl);
if Constraint_Present then
New_Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
Constraint => Relocate_Node (Constraint (Indic)));
else
declare
Expr : Node_Id;
Constr_List : List_Id := New_List;
C : Elmt_Id;
begin
C := First_Elmt (Discriminant_Constraint (Parent_Type));
while Present (C) loop
Expr := Node (C);
Append (New_Copy_Tree (Expr), To => Constr_List);
Next_Elmt (C);
end loop;
New_Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, Constr_List));
end;
end if;
Rewrite (N,
Make_Subtype_Declaration (Loc,
Defining_Identifier => Derived_Type,
Subtype_Indication => New_Indic));
Analyze (N);
Derive_Subprograms (Parent_Type, Derived_Type);
if Is_Tagged then
Set_Discriminant_Constraint
(New_Base, Discriminant_Constraint (Derived_Type));
end if;
return;
end if;
if Is_Tagged then
if not Private_Extension then
Freeze_Before (N, Parent_Type);
end if;
if Type_Access_Level (Derived_Type) /= Type_Access_Level (Parent_Type)
and then not Is_Generic_Type (Derived_Type)
then
if Is_Controlled (Parent_Type) then
Error_Msg_N
("controlled type must be declared at the library level",
Indic);
else
Error_Msg_N
("type extension at deeper accessibility level than parent",
Indic);
end if;
else
declare
GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
begin
if Present (GB)
and then GB /= Enclosing_Generic_Body (Parent_Base)
then
Error_Msg_N
("parent type must not be outside generic body",
Indic);
end if;
end;
end if;
end if;
if Has_Discriminants (Derived_Type) and then Discriminant_Specs then
Discrim := First_Discriminant (Derived_Type);
loop
Last_Discrim := Discrim;
Next_Discriminant (Discrim);
exit when No (Discrim);
end loop;
Set_Last_Entity (Derived_Type, Last_Discrim);
else
Set_First_Entity (Derived_Type, Empty);
Set_Last_Entity (Derived_Type, Empty);
end if;
Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
Set_Is_Limited_Record (Derived_Type, Is_Limited_Record (Parent_Type));
New_Scope (Derived_Type);
if Discriminant_Specs then
Set_Has_Unknown_Discriminants (Derived_Type, False);
Check_Or_Process_Discriminants (N, Derived_Type);
if not Is_Tagged and then not Has_Discriminants (Parent_Type) then
Error_Msg_N ("untagged parent must have discriminants", Indic);
elsif not Is_Tagged and then not Constraint_Present then
Error_Msg_N
("discriminant constraint needed for derived untagged records",
Indic);
elsif not Constraint_Present
and then not Private_Extension
and then not Is_Constrained (Parent_Type)
then
Error_Msg_N
("unconstrained type not allowed in this context", Indic);
elsif Constraint_Present then
Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True);
Discrim := First_Discriminant (Derived_Type);
while Present (Discrim) loop
if not Is_Tagged
and then not Present (Corresponding_Discriminant (Discrim))
then
Error_Msg_N
("new discriminants must constrain old ones", Discrim);
elsif Private_Extension
and then Present (Corresponding_Discriminant (Discrim))
then
Error_Msg_N
("Only static constraints allowed for parent"
& " discriminants in the partial view", Indic);
exit;
end if;
if Present (Corresponding_Discriminant (Discrim))
and then
not Subtypes_Statically_Compatible
(Etype (Discrim),
Etype (Corresponding_Discriminant (Discrim)))
then
Error_Msg_N
("subtype must be compatible with parent discriminant",
Discrim);
end if;
Next_Discriminant (Discrim);
end loop;
end if;
else
if Private_Extension then
Set_Has_Unknown_Discriminants
(Derived_Type, Has_Unknown_Discriminants (Parent_Type)
or else Unknown_Discriminants_Present (N));
else
Set_Has_Unknown_Discriminants
(Derived_Type, Has_Unknown_Discriminants (Parent_Type));
end if;
if not Has_Unknown_Discriminants (Derived_Type)
and then Has_Discriminants (Parent_Type)
then
Inherit_Discrims := True;
Set_Has_Discriminants
(Derived_Type, True);
Set_Discriminant_Constraint
(Derived_Type, Discriminant_Constraint (Parent_Base));
end if;
if Constraint_Present then
Discs := Build_Discriminant_Constraints (Parent_Type, Indic);
end if;
Set_Is_Constrained
(Derived_Type,
not (Inherit_Discrims
or else Has_Unknown_Discriminants (Derived_Type)));
end if;
Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
Set_Girder_Constraint (Derived_Type, No_Elist);
Set_Discard_Names
(Derived_Type, Einfo.Discard_Names (Parent_Type));
Set_Has_Specified_Layout
(Derived_Type, Has_Specified_Layout (Parent_Type));
Set_Is_Limited_Composite
(Derived_Type, Is_Limited_Composite (Parent_Type));
Set_Is_Limited_Record
(Derived_Type, Is_Limited_Record (Parent_Type));
Set_Is_Private_Composite
(Derived_Type, Is_Private_Composite (Parent_Type));
Set_Has_Controlled_Component
(Derived_Type, Has_Controlled_Component (Parent_Base));
Set_Has_Non_Standard_Rep
(Derived_Type, Has_Non_Standard_Rep (Parent_Base));
Set_Has_Primitive_Operations
(Derived_Type, Has_Primitive_Operations (Parent_Base));
if not Is_Controlled (Parent_Type) then
Set_Finalize_Storage_Only
(Derived_Type, Finalize_Storage_Only (Parent_Type));
end if;
if Is_Private_Type (Derived_Type) then
Set_Depends_On_Private (Derived_Type, True);
Set_Private_Dependents (Derived_Type, New_Elmt_List);
else
if Is_Private_Type (Parent_Base)
and then not Is_Record_Type (Parent_Base)
then
Set_Component_Alignment
(Derived_Type, Component_Alignment (Full_View (Parent_Base)));
Set_C_Pass_By_Copy
(Derived_Type, C_Pass_By_Copy (Full_View (Parent_Base)));
else
Set_Component_Alignment
(Derived_Type, Component_Alignment (Parent_Base));
Set_C_Pass_By_Copy
(Derived_Type, C_Pass_By_Copy (Parent_Base));
end if;
end if;
if Is_Tagged then
Set_Primitive_Operations (Derived_Type, New_Elmt_List);
if Chars (Scope (Derived_Type)) = Name_Finalization
and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
then
Set_Is_Controlled (Derived_Type);
else
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
end if;
Make_Class_Wide_Type (Derived_Type);
Set_Is_Abstract (Derived_Type, Abstract_Present (Type_Def));
if Has_Discriminants (Derived_Type)
and then Constraint_Present
then
Set_Girder_Constraint
(Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
end if;
else
Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
Set_Has_Non_Standard_Rep
(Derived_Type, Has_Non_Standard_Rep (Parent_Base));
end if;
if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims)
or else not Has_Discriminants (Parent_Type)
or else not Is_Constrained (Parent_Type)
then
Constrs := Discs;
else
Constrs := Discriminant_Constraint (Parent_Type);
end if;
Assoc_List := Inherit_Components (N,
Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
if not Is_Tagged then
if Has_Discriminants (Derived_Type) then
Save_Discr_Constr := Discriminant_Constraint (Derived_Type);
Set_Discriminant_Constraint (Derived_Type, No_Elist);
else
Save_Discr_Constr := No_Elist;
end if;
Save_Etype := Etype (Derived_Type);
Save_Next_Entity := Next_Entity (Derived_Type);
New_Decl :=
New_Copy_Tree
(Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
Set_Etype (Derived_Type, Save_Etype);
Set_Next_Entity (Derived_Type, Save_Next_Entity);
if Has_Discriminants (Derived_Type) then
Set_Discriminant_Constraint
(Derived_Type, Save_Discr_Constr);
Set_Girder_Constraint
(Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
Replace_Components (Derived_Type, New_Decl);
end if;
Rewrite (N, New_Decl);
elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
Record_Type_Definition (Empty, Derived_Type);
elsif not Private_Extension then
Expand_Derived_Record (Derived_Type, Type_Def);
Record_Type_Definition
(Record_Extension_Part (Type_Def), Derived_Type);
end if;
End_Scope;
if Etype (Derived_Type) = Any_Type then
return;
end if;
Set_Has_Delayed_Freeze (Derived_Type);
if Derive_Subps then
Derive_Subprograms (Parent_Type, Derived_Type);
end if;
if Private_Extension and then Inherit_Discrims then
if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then
Set_Is_Constrained (Derived_Type, True);
Set_Discriminant_Constraint (Derived_Type, Discs);
elsif Is_Constrained (Parent_Type) then
Set_Is_Constrained
(Derived_Type, True);
Set_Discriminant_Constraint
(Derived_Type, Discriminant_Constraint (Parent_Type));
end if;
end if;
end Build_Derived_Record_Type;
procedure Build_Derived_Type
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Is_Completion : Boolean;
Derive_Subps : Boolean := True)
is
Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
begin
Set_Scope (Derived_Type, Current_Scope);
Set_Ekind (Derived_Type, Ekind (Parent_Base));
Set_Etype (Derived_Type, Parent_Base);
Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
Set_Size_Info (Derived_Type, Parent_Type);
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
Set_Convention (Derived_Type, Convention (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
case Ekind (Parent_Type) is
when Numeric_Kind =>
Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);
when Array_Kind =>
Build_Derived_Array_Type (N, Parent_Type, Derived_Type);
when E_Record_Type
| E_Record_Subtype
| Class_Wide_Kind =>
Build_Derived_Record_Type
(N, Parent_Type, Derived_Type, Derive_Subps);
return;
when Enumeration_Kind =>
Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type);
when Access_Kind =>
Build_Derived_Access_Type (N, Parent_Type, Derived_Type);
when Incomplete_Or_Private_Kind =>
Build_Derived_Private_Type
(N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps);
if Is_Tagged_Type (Parent_Type)
or else Has_Discriminants (Parent_Type)
or else (Present (Full_View (Parent_Type))
and then Has_Discriminants (Full_View (Parent_Type)))
then
return;
end if;
when Concurrent_Kind =>
Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type);
when others =>
raise Program_Error;
end case;
if Etype (Derived_Type) = Any_Type then
return;
end if;
Set_Has_Delayed_Freeze (Derived_Type);
if Derive_Subps then
Derive_Subprograms (Parent_Type, Derived_Type);
end if;
Set_Has_Primitive_Operations
(Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type));
end Build_Derived_Type;
procedure Build_Discriminal (Discrim : Entity_Id) is
D_Minal : Entity_Id;
CR_Disc : Entity_Id;
begin
D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
Set_Ekind (D_Minal, E_In_Parameter);
Set_Mechanism (D_Minal, Default_Mechanism);
Set_Etype (D_Minal, Etype (Discrim));
Set_Discriminal (Discrim, D_Minal);
Set_Discriminal_Link (D_Minal, Discrim);
if Is_Concurrent_Type (Current_Scope)
or else Is_Limited_Type (Current_Scope)
then
CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
Set_Ekind (CR_Disc, E_In_Parameter);
Set_Mechanism (CR_Disc, Default_Mechanism);
Set_Etype (CR_Disc, Etype (Discrim));
Set_CR_Discriminant (Discrim, CR_Disc);
end if;
end Build_Discriminal;
function Build_Discriminant_Constraints
(T : Entity_Id;
Def : Node_Id;
Derived_Def : Boolean := False)
return Elist_Id
is
C : constant Node_Id := Constraint (Def);
Nb_Discr : constant Nat := Number_Discriminants (T);
Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty);
function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat;
function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is
Disc : Entity_Id;
begin
Disc := First_Discriminant (T);
for J in Discr_Expr'Range loop
if Disc = D then
return J;
end if;
Next_Discriminant (Disc);
end loop;
raise Program_Error;
end Pos_Of_Discr;
Discr : Entity_Id;
E : Entity_Id;
Elist : Elist_Id := New_Elmt_List;
Constr : Node_Id;
Expr : Node_Id;
Id : Node_Id;
Position : Nat;
Found : Boolean;
Discrim_Present : Boolean := False;
begin
Discr := First_Discriminant (T);
Constr := First (Constraints (C));
for D in Discr_Expr'Range loop
exit when Nkind (Constr) = N_Discriminant_Association;
if No (Constr) then
Error_Msg_N ("too few discriminants given in constraint", C);
return New_Elmt_List;
elsif Nkind (Constr) = N_Range
or else (Nkind (Constr) = N_Attribute_Reference
and then
Attribute_Name (Constr) = Name_Range)
then
Error_Msg_N
("a range is not a valid discriminant constraint", Constr);
Discr_Expr (D) := Error;
else
Analyze_And_Resolve (Constr, Base_Type (Etype (Discr)));
Discr_Expr (D) := Constr;
end if;
Next_Discriminant (Discr);
Next (Constr);
end loop;
if No (Discr) and then Present (Constr) then
Error_Msg_N ("too many discriminants given in constraint", Constr);
return New_Elmt_List;
end if;
while Present (Constr) loop
if Nkind (Constr) /= N_Discriminant_Association then
Error_Msg_N ("positional association follows named one", Constr);
return New_Elmt_List;
else
E := Empty;
Id := First (Selector_Names (Constr));
while Present (Id) loop
Found := False;
if Present (Original_Discriminant (Id)) then
Discr := Find_Corresponding_Discriminant (Id, T);
Found := True;
else
Discr := First_Discriminant (T);
while Present (Discr) loop
if Chars (Discr) = Chars (Id) then
Found := True;
exit;
end if;
Next_Discriminant (Discr);
end loop;
if not Found then
Error_Msg_N ("& does not match any discriminant", Id);
return New_Elmt_List;
else
Set_Original_Discriminant (Id, Discr);
end if;
end if;
Position := Pos_Of_Discr (T, Discr);
if Present (Discr_Expr (Position)) then
Error_Msg_N ("duplicate constraint for discriminant&", Id);
else
if Present (Next (Id)) then
Expr := New_Copy_Tree (Expression (Constr));
Set_Parent (Expr, Parent (Expression (Constr)));
else
Expr := Expression (Constr);
end if;
Discr_Expr (Position) := Expr;
Analyze_And_Resolve (Expr, Base_Type (Etype (Discr)));
end if;
if E = Empty then
E := Base_Type (Etype (Discr));
elsif Base_Type (Etype (Discr)) /= E then
Error_Msg_N
("all discriminants in an association " &
"must have the same type", Id);
end if;
Next (Id);
end loop;
end if;
Next (Constr);
end loop;
for J in Discr_Expr'Range loop
if No (Discr_Expr (J)) then
Error_Msg_N ("too few discriminants given in constraint", C);
return New_Elmt_List;
end if;
end loop;
for J in Discr_Expr'Range loop
if Denotes_Discriminant (Discr_Expr (J)) then
Discrim_Present := True;
end if;
end loop;
Discr := First_Discriminant (T);
for J in Discr_Expr'Range loop
if Discr_Expr (J) /= Error then
Append_Elmt (Discr_Expr (J), Elist);
if Denotes_Discriminant (Discr_Expr (J)) then
if Derived_Def then
Set_Corresponding_Discriminant
(Entity (Discr_Expr (J)), Discr);
end if;
else
if not Discrim_Present then
Apply_Range_Check (Discr_Expr (J), Etype (Discr));
end if;
Force_Evaluation (Discr_Expr (J));
end if;
if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
and then not Is_Class_Wide_Type
(Designated_Type (Etype (Discr)))
and then Etype (Discr_Expr (J)) /= Any_Type
and then Is_Class_Wide_Type
(Designated_Type (Etype (Discr_Expr (J))))
then
Wrong_Type (Discr_Expr (J), Etype (Discr));
end if;
end if;
Next_Discriminant (Discr);
end loop;
return Elist;
end Build_Discriminant_Constraints;
procedure Build_Discriminated_Subtype
(T : Entity_Id;
Def_Id : Entity_Id;
Elist : Elist_Id;
Related_Nod : Node_Id;
For_Access : Boolean := False)
is
Has_Discrs : constant Boolean := Has_Discriminants (T);
Constrained : constant Boolean
:= (Has_Discrs
and then not Is_Empty_Elmt_List (Elist)
and then not Is_Class_Wide_Type (T))
or else Is_Constrained (T);
begin
if Ekind (T) = E_Record_Type then
if For_Access then
Set_Ekind (Def_Id, E_Private_Subtype);
Set_Is_For_Access_Subtype (Def_Id, True);
else
Set_Ekind (Def_Id, E_Record_Subtype);
end if;
elsif Ekind (T) = E_Task_Type then
Set_Ekind (Def_Id, E_Task_Subtype);
elsif Ekind (T) = E_Protected_Type then
Set_Ekind (Def_Id, E_Protected_Subtype);
elsif Is_Private_Type (T) then
Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
elsif Is_Class_Wide_Type (T) then
Set_Ekind (Def_Id, E_Class_Wide_Subtype);
else
Set_Ekind (Def_Id, Ekind (T));
Append_Elmt (Def_Id, Private_Dependents (T));
end if;
Set_Etype (Def_Id, T);
Init_Size_Align (Def_Id);
Set_Has_Discriminants (Def_Id, Has_Discrs);
Set_Is_Constrained (Def_Id, Constrained);
Set_First_Entity (Def_Id, First_Entity (T));
Set_Last_Entity (Def_Id, Last_Entity (T));
Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Def_Id);
Make_Class_Wide_Type (Def_Id);
end if;
Set_Girder_Constraint (Def_Id, No_Elist);
if Has_Discrs then
Set_Discriminant_Constraint (Def_Id, Elist);
Set_Girder_Constraint_From_Discriminant_Constraint (Def_Id);
end if;
if Is_Tagged_Type (T) then
Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
Set_Is_Abstract (Def_Id, Is_Abstract (T));
end if;
if not Is_Type (Scope (Def_Id)) then
Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
if Is_Private_Type (T)
and then Present (Full_View (T))
then
Conditional_Delay (Def_Id, Full_View (T));
else
Conditional_Delay (Def_Id, T);
end if;
end if;
if Is_Record_Type (T) then
Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T));
if Has_Discrs
and then not Is_Empty_Elmt_List (Elist)
and then not For_Access
then
Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
elsif not For_Access then
Set_Cloned_Subtype (Def_Id, T);
end if;
end if;
end Build_Discriminated_Subtype;
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
Der_T : Entity_Id)
return Node_Id
is
New_Bound : Entity_Id;
begin
Analyze_And_Resolve (Bound, Base_Type (Par_T));
if Nkind (Bound) = N_Integer_Literal
or else Nkind (Bound) = N_Real_Literal
then
New_Bound := New_Copy (Bound);
Set_Etype (New_Bound, Der_T);
Set_Analyzed (New_Bound);
elsif Is_Entity_Name (Bound) then
New_Bound := OK_Convert_To (Der_T, New_Copy (Bound));
else
New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound));
end if;
Set_Etype (New_Bound, Der_T);
return New_Bound;
end Build_Scalar_Bound;
procedure Build_Underlying_Full_View
(N : Node_Id;
Typ : Entity_Id;
Par : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Subt : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_External_Name (Chars (Typ), 'S'));
Constr : Node_Id;
Indic : Node_Id;
C : Node_Id;
Id : Node_Id;
begin
if Nkind (N) = N_Full_Type_Declaration then
Constr := Constraint (Subtype_Indication (Type_Definition (N)));
else pragma Assert (Nkind (N) = N_Subtype_Declaration);
Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
end if;
C := First (Constraints (Constr));
while Present (C) loop
if Nkind (C) = N_Discriminant_Association then
Id := First (Selector_Names (C));
while Present (Id) loop
Set_Original_Discriminant (Id, Empty);
Next (Id);
end loop;
end if;
Next (C);
end loop;
Indic := Make_Subtype_Declaration (Loc,
Defining_Identifier => Subt,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (Par, Loc),
Constraint => New_Copy_Tree (Constr)));
Insert_Before (N, Indic);
Analyze (Indic);
Set_Underlying_Full_View (Typ, Full_View (Subt));
end Build_Underlying_Full_View;
procedure Check_Abstract_Overriding (T : Entity_Id) is
Op_List : Elist_Id;
Elmt : Elmt_Id;
Subp : Entity_Id;
Type_Def : Node_Id;
begin
Op_List := Primitive_Operations (T);
Elmt := First_Elmt (Op_List);
while Present (Elmt) loop
Subp := Node (Elmt);
if Is_Abstract (Subp)
and then Chars (Subp) /= Name_uInput
and then Chars (Subp) /= Name_uOutput
and then not Is_Abstract (T)
then
if Present (Alias (Subp)) then
Type_Def := Type_Definition (Parent (T));
if Nkind (Type_Def) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Type_Def))
then
Error_Msg_NE
("type must be declared abstract or & overridden",
T, Subp);
end if;
else
Error_Msg_NE
("abstract subprogram not allowed for type&",
Subp, T);
Error_Msg_NE
("nonabstract type has abstract subprogram&",
T, Subp);
end if;
end if;
Next_Elmt (Elmt);
end loop;
end Check_Abstract_Overriding;
procedure Check_Access_Discriminant_Requires_Limited
(D : Node_Id;
Loc : Node_Id)
is
begin
if Nkind (Discriminant_Type (D)) = N_Access_Definition
and then not Is_Concurrent_Type (Current_Scope)
and then not Is_Concurrent_Record_Type (Current_Scope)
and then not Is_Limited_Record (Current_Scope)
and then Ekind (Current_Scope) /= E_Limited_Private_Type
then
Error_Msg_N
("access discriminants allowed only for limited types", Loc);
end if;
end Check_Access_Discriminant_Requires_Limited;
procedure Check_Aliased_Component_Types (T : Entity_Id) is
C : Entity_Id;
begin
if not Is_Limited_Type (T) then
if Ekind (T) = E_Record_Type then
C := First_Component (T);
while Present (C) loop
if Is_Aliased (C)
and then Has_Discriminants (Etype (C))
and then not Is_Constrained (Etype (C))
and then not In_Instance
then
Error_Msg_N
("aliased component must be constrained ('R'M 3.6(11))",
C);
end if;
Next_Component (C);
end loop;
elsif Ekind (T) = E_Array_Type then
if Has_Aliased_Components (T)
and then Has_Discriminants (Component_Type (T))
and then not Is_Constrained (Component_Type (T))
and then not In_Instance
then
Error_Msg_N
("aliased component type must be constrained ('R'M 3.6(11))",
T);
end if;
end if;
end if;
end Check_Aliased_Component_Types;
procedure Check_Completion (Body_Id : Node_Id := Empty) is
E : Entity_Id;
procedure Post_Error;
procedure Post_Error is
begin
if not Comes_From_Source (E) then
if (Ekind (E) = E_Task_Type
or else Ekind (E) = E_Protected_Type)
then
declare
Var : Entity_Id;
begin
Var := First_Entity (Current_Scope);
while Present (Var) loop
exit when Etype (Var) = E
and then Comes_From_Source (Var);
Next_Entity (Var);
end loop;
if Present (Var) then
E := Var;
end if;
end;
end if;
end if;
if not Comes_From_Source (E) then
pragma Assert
(Serious_Errors_Detected > 0
or else Subunits_Missing
or else not Expander_Active);
return;
else
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;
else
Error_Msg_Sloc := Sloc (E);
if Is_Type (E) then
Error_Msg_NE
("missing full declaration for }!", Body_Id, E);
elsif Is_Overloadable (E)
and then Current_Entity_In_Scope (E) /= E
then
declare
Candidate : Entity_Id := Current_Entity_In_Scope (E);
Decl : Node_Id := Unit_Declaration_Node (Candidate);
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);
else
Error_Msg_NE ("missing body for & declared#!",
Body_Id, E);
end if;
end;
else
Error_Msg_NE ("missing body for & declared#!",
Body_Id, E);
end if;
end if;
end if;
end Post_Error;
begin
E := First_Entity (Current_Scope);
while Present (E) loop
if Is_Intrinsic_Subprogram (E) then
null;
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 not Has_Completion (E)
and then not Is_Abstract (E)
and then Nkind (Parent (Unit_Declaration_Node (E))) /=
N_Compilation_Unit
and then Chars (E) /= Name_uSize
then
Post_Error;
end if;
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 Is_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;
elsif not Is_Child_Unit (E) then
May_Need_Implicit_Body (E);
end if;
elsif Ekind (E) = E_Incomplete_Type
and then No (Underlying_Type (E))
then
Post_Error;
elsif (Ekind (E) = E_Task_Type or else
Ekind (E) = E_Protected_Type)
and then not Has_Completion (E)
then
Post_Error;
elsif Ekind (E) = E_Constant
and then Ekind (Etype (E)) = E_Task_Type
and then not Has_Completion (Etype (E))
then
Post_Error;
elsif Ekind (E) = E_Protected_Object
and then not Has_Completion (Etype (E))
then
Post_Error;
elsif Ekind (E) = E_Record_Type then
if Is_Tagged_Type (E) then
Check_Abstract_Overriding (E);
end if;
Check_Aliased_Component_Types (E);
elsif Ekind (E) = E_Array_Type then
Check_Aliased_Component_Types (E);
end if;
Next_Entity (E);
end loop;
end Check_Completion;
procedure Check_Delta_Expression (E : Node_Id) is
begin
if not (Is_Real_Type (Etype (E))) then
Wrong_Type (E, Any_Real);
elsif not Is_OK_Static_Expression (E) then
Error_Msg_N ("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 (E,
Make_Real_Literal (Sloc (E), Ureal_Tenth));
Analyze_And_Resolve (E, Standard_Float);
end Check_Delta_Expression;
procedure Check_Digits_Expression (E : Node_Id) is
begin
if not (Is_Integer_Type (Etype (E))) then
Wrong_Type (E, Any_Integer);
elsif not Is_OK_Static_Expression (E) then
Error_Msg_N ("non-static expression used for digits value", E);
elsif Expr_Value (E) <= 0 then
Error_Msg_N ("digits value must be greater than zero", E);
else
return;
end if;
Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
Analyze_And_Resolve (E, Standard_Integer);
end Check_Digits_Expression;
procedure Check_Incomplete (T : Entity_Id) is
begin
if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type then
Error_Msg_N ("invalid use of type before its full declaration", T);
end if;
end Check_Incomplete;
procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
begin
if (Is_Limited_Type (T)
or else Is_Limited_Composite (T))
and then not In_Instance
then
Error_Msg_N
("cannot initialize entities of limited type", Exp);
end if;
end Check_Initialization;
procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id) is
begin
if Has_Discriminants (T) then
declare
D : Entity_Id := First_Discriminant (T);
Prev : Entity_Id;
begin
while Present (D) loop
Prev := Current_Entity (D);
Set_Current_Entity (D);
Set_Is_Immediately_Visible (D);
Set_Homonym (D, Prev);
Check_Access_Discriminant_Requires_Limited (Parent (D), N);
Next_Discriminant (D);
end loop;
end;
elsif Present (Discriminant_Specifications (N)) then
Process_Discriminants (N);
end if;
end Check_Or_Process_Discriminants;
procedure Check_Real_Bound (Bound : 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);
elsif not Is_OK_Static_Expression (Bound) then
Error_Msg_N
("non-static expression used for real type bound", Bound);
else
return;
end if;
Rewrite
(Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
Analyze (Bound);
Resolve (Bound, Standard_Float);
end Check_Real_Bound;
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;
begin
Save_Next_Entity := Next_Entity (Full);
Save_Homonym := Homonym (Priv);
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);
Set_Has_Discriminants (Full, Has_Discriminants (Full_Base));
Set_First_Entity (Full, First_Entity (Full_Base));
Set_Last_Entity (Full, Last_Entity (Full_Base));
when others =>
Copy_Node (Full_Base, Full);
Set_Chars (Full, Chars (Priv));
Conditional_Delay (Full, Priv);
Set_Sloc (Full, Sloc (Priv));
end case;
Set_Next_Entity (Full, Save_Next_Entity);
Set_Homonym (Full, Save_Homonym);
Set_Associated_Node_For_Itype (Full, Related_Nod);
Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
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 not Has_Discriminants (Priv) then
Set_Is_Constrained (Full, Is_Constrained (Full_Base));
end if;
Set_First_Rep_Item (Full, First_Rep_Item (Full_Base));
Set_Depends_On_Private (Full, Has_Private_Component (Full));
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_Girder_Constraint_From_Discriminant_Constraint (Full);
Set_Girder_Constraint (Priv, Girder_Constraint (Full));
if Has_Unknown_Discriminants (Full) then
Set_Discriminant_Constraint (Full, No_Elist);
end if;
end if;
if Ekind (Full_Base) = E_Record_Type
and then Has_Discriminants (Full_Base)
and then Has_Discriminants (Priv) and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
then
Create_Constrained_Components
(Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
elsif Ekind (Full_Base) in Private_Kind
and then Is_Derived_Type (Full_Base)
and then Has_Discriminants (Full_Base)
and then
Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
then
Build_Underlying_Full_View (Parent (Priv), Full, Etype (Full_Base));
elsif Is_Record_Type (Full_Base) then
Set_Cloned_Subtype (Full, Full_Base);
end if;
if Is_Scalar_Type (Full_Base) then
Set_Scalar_Range (Full,
Make_Range (Sloc (Related_Nod),
Low_Bound => Duplicate_Subexpr (Type_Low_Bound (Full_Base)),
High_Bound => Duplicate_Subexpr (Type_High_Bound (Full_Base))));
end if;
if Is_Tagged_Type (Full_Base) then
Set_Is_Tagged_Type (Full);
Set_Primitive_Operations (Full, Primitive_Operations (Full_Base));
elsif Is_Concurrent_Type (Full_Base) then
if Has_Discriminants (Full)
and then Present (Corresponding_Record_Type (Full_Base))
then
Set_Corresponding_Record_Type (Full,
Constrain_Corresponding_Record
(Full, Corresponding_Record_Type (Full_Base),
Related_Nod, Full_Base));
else
Set_Corresponding_Record_Type (Full,
Corresponding_Record_Type (Full_Base));
end if;
end if;
end Complete_Private_Subtype;
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;
procedure Check_Recursive_Declaration (Typ : Entity_Id);
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;
elsif Is_Record_Type (Etype (Comp)) then
Check_Recursive_Declaration (Etype (Comp));
end if;
end if;
Next_Component (Comp);
end loop;
end if;
end Check_Recursive_Declaration;
begin
if Nkind (Parent (Prev)) = N_Object_Declaration then
if Nkind (Object_Definition
(Parent (Prev))) = N_Subtype_Indication
then
if Nkind (Obj_Def) = N_Subtype_Indication then
Find_Type (Subtype_Mark (Obj_Def));
New_T := Entity (Subtype_Mark (Obj_Def));
else
Find_Type (Obj_Def);
New_T := Entity (Obj_Def);
end if;
T := Etype (Prev);
else
New_T := Find_Type_Of_Object (Obj_Def, N);
T := New_T;
end if;
else
T := Empty;
New_T := Any_Type;
end if;
if Ekind (Prev) /= E_Constant
or else Present (Expression (Parent (Prev)))
or else Present (Full_View (Prev))
then
Enter_Name (Id);
elsif Base_Type (Etype (Prev)) /= Base_Type (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);
else
Set_Full_View (Prev, Id);
Set_Is_Public (Id, Is_Public (Prev));
Set_Is_Internal (Id);
Append_Entity (Id, Current_Scope);
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;
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);
elsif Ekind (Current_Scope) = E_Package
and then List_Containing (Parent (Prev))
/= Visible_Declarations
(Specification (Unit_Declaration_Node (Current_Scope)))
then
Error_Msg_N
("deferred constant must be declared in visible part",
Parent (Prev));
end if;
if Is_Access_Type (T)
and then Nkind (Expression (N)) = N_Allocator
then
Check_Recursive_Declaration (Designated_Type (T));
end if;
end if;
end Constant_Redeclaration;
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;
begin
if Is_Array_Type (Desig_Type) then
Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
elsif (Is_Record_Type (Desig_Type)
or else Is_Incomplete_Or_Private_Type (Desig_Type))
and then not Is_Constrained (Desig_Type)
then
if Desig_Type = Current_Scope
and then No (Def_Id)
then
Set_Ekind (Desig_Subtype, E_Record_Subtype);
Def_Id := Entity (Subtype_Mark (S));
Constrain_Discriminated_Type
(Desig_Subtype, S, Related_Nod, For_Access => True);
return;
end if;
if Ekind (T) = E_General_Access_Type
and then Has_Private_Declaration (Desig_Type)
and then In_Open_Scopes (Scope (Desig_Type))
then
declare
Pack : Node_Id := Unit_Declaration_Node (Scope (Desig_Type));
Decls : List_Id;
Decl : Node_Id;
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 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 general access type " &
"if designated type has unconstrained view", S);
end if;
exit;
end if;
Next (Decl);
end loop;
end if;
end;
end if;
Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
For_Access => True);
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, ' ');
else
Error_Msg_N ("invalid constraint on access type", S);
Desig_Subtype := Desig_Type; Constraint_OK := False;
end if;
if No (Def_Id) then
Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
else
Set_Ekind (Def_Id, E_Access_Subtype);
end if;
if Constraint_OK then
Set_Etype (Def_Id, Base_Type (T));
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;
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));
if not Is_Record_Type (Current_Scope) then
Conditional_Delay (Def_Id, T);
end if;
end Constrain_Access;
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;
begin
T := Entity (Subtype_Mark (SI));
if Ekind (T) in Access_Kind then
T := Designated_Type (T);
end if;
if Is_Constrained (T) then
Error_Msg_N
("array type is already constrained", Subtype_Mark (SI));
Constraint_OK := False;
else
S := First (Constraints (C));
while Present (S) loop
Number_Of_Constraints := Number_Of_Constraints + 1;
Next (S);
end loop;
if Number_Of_Constraints /= Number_Dimensions (T) then
Error_Msg_NE ("incorrect number of index constraints for }", C, T);
Constraint_OK := False;
else
S := First (Constraints (C));
Index := First_Index (T);
Analyze (Index);
for J in 1 .. Number_Of_Constraints loop
Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
Next (Index);
Next (S);
end loop;
end if;
end if;
if No (Def_Id) then
Def_Id :=
Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
else
Set_Ekind (Def_Id, E_Array_Subtype);
end if;
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)));
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));
if not Is_Type (Scope (Def_Id)) then
Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
Conditional_Delay (Def_Id, T);
end if;
end Constrain_Array;
function Constrain_Component_Type
(Compon_Type : 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);
function Build_Constrained_Array_Type
(Old_Type : Entity_Id)
return Entity_Id;
function Build_Constrained_Discriminated_Type
(Old_Type : Entity_Id)
return Entity_Id;
function Build_Constrained_Access_Type
(Old_Type : Entity_Id)
return Entity_Id;
function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
function Is_Discriminant (Expr : Node_Id) return Boolean;
function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
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;
begin
if not Is_Type (Scope (Old_Type)) then
return Old_Type;
elsif Is_Array_Type (Desig_Type) then
Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
elsif Has_Discriminants (Desig_Type) then
Desig_Subtype := Any_Type;
for J in reverse 0 .. Scope_Stack.Last loop
Scop := Scope_Stack.Table (J).Entity;
if Is_Type (Scop)
and then Base_Type (Scop) = Base_Type (Desig_Type)
then
Desig_Subtype := Scop;
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;
else
return Old_Type;
end if;
if Desig_Subtype /= Desig_Type then
pragma Assert (Present (Related_Node));
Itype := Create_Itype (E_Access_Subtype, Related_Node);
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_Delayed_Freeze (Constrained_Typ)
and then not Is_Frozen (Constrained_Typ)
then
Conditional_Delay (Itype, Base_Type (Old_Type));
end if;
return Itype;
else
return Old_Type;
end if;
end Build_Constrained_Access_Type;
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;
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 Is_Discriminant (Lo_Expr)
or else Is_Discriminant (Hi_Expr)
then
Need_To_Create_Itype := True;
end if;
Next_Index (Old_Index);
end loop;
if Need_To_Create_Itype then
Constr_List := New_List;
Old_Index := First_Index (Old_Type);
while Present (Old_Index) loop
Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
if Is_Discriminant (Lo_Expr) then
Lo_Expr := Get_Discr_Value (Lo_Expr);
end if;
if Is_Discriminant (Hi_Expr) then
Hi_Expr := Get_Discr_Value (Hi_Expr);
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);
end loop;
return Build_Subtype (Old_Type, Constr_List);
else
return Old_Type;
end if;
end Build_Constrained_Array_Type;
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
Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
while Present (Old_Constraint) loop
Expr := Node (Old_Constraint);
if Is_Discriminant (Expr) then
Need_To_Create_Itype := True;
end if;
Next_Elmt (Old_Constraint);
end loop;
if Need_To_Create_Itype then
Constr_List := New_List;
Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
while Present (Old_Constraint) loop
Expr := Node (Old_Constraint);
if Is_Discriminant (Expr) then
Expr := Get_Discr_Value (Expr);
end if;
Append (New_Copy_Tree (Expr), To => Constr_List);
Next_Elmt (Old_Constraint);
end loop;
return Build_Subtype (Old_Type, Constr_List);
else
return Old_Type;
end if;
end Build_Constrained_Discriminated_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);
begin
pragma Assert (Present (Related_Node));
if Has_Unknown_Discriminants (Btyp)
and then Present (Underlying_Type (Btyp))
then
Btyp := Underlying_Type (Btyp);
end if;
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
Def_Id := Create_Itype (Ekind (T), Related_Node);
Subtyp_Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Def_Id,
Subtype_Indication => Indic);
Set_Parent (Subtyp_Decl, Parent (Related_Node));
Analyze (Subtyp_Decl, Suppress => All_Checks);
return Def_Id;
end Build_Subtype;
function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
D : Entity_Id := First_Discriminant (Typ);
E : Elmt_Id := First_Elmt (Constraints);
G : Elmt_Id;
begin
while Present (D) loop
if D = Entity (Discrim)
or else Corresponding_Discriminant (D) = Entity (Discrim)
then
return Node (E);
end if;
Next_Discriminant (D);
Next_Elmt (E);
end loop;
if Is_Derived_Type (Typ)
and then Present (Girder_Constraint (Typ))
and then Scope (Entity (Discrim)) = Etype (Typ)
then
D := First_Discriminant (Etype (Typ));
E := First_Elmt (Constraints);
G := First_Elmt (Girder_Constraint (Typ));
while Present (D) loop
if D = Entity (Discrim) then
return Node (E);
end if;
Next_Discriminant (D);
Next_Elmt (E);
Next_Elmt (G);
end loop;
end if;
raise Program_Error;
end Get_Discr_Value;
function Is_Discriminant (Expr : Node_Id) return Boolean is
Discrim_Scope : Entity_Id;
begin
if Denotes_Discriminant (Expr) then
Discrim_Scope := Scope (Entity (Expr));
pragma Assert (Discrim_Scope = Typ
or else Discrim_Scope = Etype (Typ)
or else Full_View (Discrim_Scope) = Etype (Typ)
or else (Is_Private_Type (Discrim_Scope)
and then Chars (Discrim_Scope) = Chars (Typ))
or else (Is_Private_Type (Typ)
and then Chars (Discrim_Scope) = Chars (Typ))
or else (Is_Class_Wide_Type (Typ)
and then Etype (Typ) = Discrim_Scope));
return True;
end if;
return False;
end Is_Discriminant;
begin
if 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);
end if;
return Compon_Type;
end Constrain_Component_Type;
procedure Constrain_Concurrent
(Def_Id : in out Entity_Id;
SI : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id;
Suffix : Character)
is
T_Ent : Entity_Id := Entity (Subtype_Mark (SI));
T_Val : Entity_Id;
begin
if Ekind (T_Ent) in Access_Kind then
T_Ent := Designated_Type (T_Ent);
end if;
T_Val := Corresponding_Record_Type (T_Ent);
if Present (T_Val) then
if No (Def_Id) then
Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
end if;
Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
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, Related_Id));
else
if No (Def_Id) then
Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
end if;
Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
end if;
end Constrain_Concurrent;
function Constrain_Corresponding_Record
(Prot_Subt : Entity_Id;
Corr_Rec : Entity_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id)
return Entity_Id
is
T_Sub : constant Entity_Id
:= Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V');
begin
Set_Etype (T_Sub, Corr_Rec);
Init_Size_Align (T_Sub);
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));
Conditional_Delay (T_Sub, Corr_Rec);
if Has_Discriminants (Prot_Subt) then Set_Discriminant_Constraint (T_Sub,
Discriminant_Constraint (Prot_Subt));
Set_Girder_Constraint_From_Discriminant_Constraint (T_Sub);
Create_Constrained_Components (T_Sub, Related_Nod, Corr_Rec,
Discriminant_Constraint (T_Sub));
end if;
Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub));
return T_Sub;
end Constrain_Corresponding_Record;
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
Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
if Nkind (C) = N_Range_Constraint then
Range_Expr := Range_Expression (C);
Digits_Val := Digits_Value (T);
else
pragma Assert (Nkind (C) = N_Digits_Constraint);
Digits_Expr := Digits_Expression (C);
Analyze_And_Resolve (Digits_Expr, Any_Integer);
Check_Digits_Expression (Digits_Expr);
Digits_Val := Expr_Value (Digits_Expr);
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 Present (Range_Constraint (C)) then
Range_Expr := Range_Expression (Range_Constraint (C));
else
Range_Expr := Empty;
end if;
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));
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);
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_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T);
Set_Discrete_RM_Size (Def_Id);
Set_Has_Delayed_Freeze (Def_Id);
end Constrain_Decimal;
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;
procedure Fixup_Bad_Constraint;
procedure Fixup_Bad_Constraint is
begin
if Ekind (T) = E_Incomplete_Type then
Set_Ekind (Def_Id, Ekind (T));
else
Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
end if;
Set_Etype (Def_Id, Any_Type);
Set_Error_Posted (Def_Id);
end Fixup_Bad_Constraint;
begin
C := Constraint (S);
T := Base_Type (Entity (Subtype_Mark (S)));
if Ekind (T) in Access_Kind then
T := Designated_Type (T);
end if;
if not Has_Discriminants (T) then
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;
T := Base_Type (T);
Elist := Build_Discriminant_Constraints (T, S);
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;
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);
begin
Set_Ekind (Def_Id, E_Enumeration_Subtype);
Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
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));
Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
Set_Discrete_RM_Size (Def_Id);
end Constrain_Enumeration;
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
Set_Ekind (Def_Id, E_Floating_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));
C := Constraint (S);
if Nkind (C) = N_Digits_Constraint then
D := Digits_Expression (C);
Analyze_And_Resolve (D, Any_Integer);
Check_Digits_Expression (D);
Set_Digits_Value (Def_Id, Expr_Value (D));
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;
C := Range_Constraint (C);
else
Set_Digits_Value (Def_Id, Digits_Value (T));
end if;
if Nkind (C) = N_Range_Constraint then
Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
else
pragma Assert (No (C));
Set_Scalar_Range (Def_Id, Scalar_Range (T));
end if;
Set_Is_Constrained (Def_Id);
end Constrain_Float;
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;
Checks_Off : Boolean := False;
T : constant Entity_Id := Etype (Index);
begin
if Nkind (S) = N_Range
or else Nkind (S) = N_Attribute_Reference
then
Analyze (S);
Set_Etype (S, T);
R := S;
if Nkind (R) = N_Range
and then Nkind (Low_Bound (R)) = N_Attribute_Reference
and then Nkind (High_Bound (R)) = N_Attribute_Reference
then
Checks_Off := True;
end if;
Process_Range_Expr_In_Decl (R, T, Empty_List, Checks_Off);
if not Error_Posted (S)
and then
(Nkind (S) /= N_Range
or else Base_Type (T) /= Base_Type (Etype (Low_Bound (S)))
or else Base_Type (T) /= Base_Type (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;
elsif Nkind (S) = N_Subtype_Indication then
Resolve_Discrete_Subtype_Indication (S, T);
R := Range_Expression (Constraint (S));
elsif Nkind (S) = N_Discriminant_Association then
Error_Msg_N ("invalid index constraint", S);
Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
return;
else
Analyze (S);
if Is_Entity_Name (S) then
if not Is_Type (Entity (S)) then
Error_Msg_N ("expect subtype mark for index constraint", S);
elsif Base_Type (Entity (S)) /= Base_Type (T) then
Wrong_Type (S, Base_Type (T));
end if;
return;
else
Error_Msg_N ("invalid index constraint", S);
Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
return;
end if;
end if;
Def_Id :=
Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
Set_Etype (Def_Id, Base_Type (T));
if Is_Modular_Integer_Type (T) then
Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
elsif Is_Integer_Type (T) then
Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
else
Set_Ekind (Def_Id, E_Enumeration_Subtype);
Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
end if;
Set_Size_Info (Def_Id, (T));
Set_RM_Size (Def_Id, RM_Size (T));
Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
Set_Scalar_Range (Def_Id, R);
Set_Etype (S, Def_Id);
Set_Discrete_RM_Size (Def_Id);
end Constrain_Index;
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);
begin
Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
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;
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;
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;
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));
C := Constraint (S);
if Nkind (C) = N_Delta_Constraint then
D := Delta_Expression (C);
Analyze_And_Resolve (D, Any_Real);
Check_Delta_Expression (D);
Set_Delta_Value (Def_Id, Expr_Value_R (D));
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;
C := Range_Constraint (C);
else
Set_Delta_Value (Def_Id, Delta_Value (T));
end if;
if Nkind (C) = N_Range_Constraint then
Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
else
pragma Assert (No (C));
Set_Scalar_Range (Def_Id, Scalar_Range (T));
end if;
Set_Discrete_RM_Size (Def_Id);
Set_Has_Delayed_Freeze (Def_Id);
end Constrain_Ordinary_Fixed;
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);
Lo : Node_Id;
Hi : Node_Id;
Rng : Node_Id;
begin
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);
Rng :=
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi);
Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type));
Set_Parent (Rng, N);
Set_Scalar_Range (Derived_Type, Rng);
Analyze_And_Resolve (Lo, Implicit_Base);
Analyze_And_Resolve (Hi, Implicit_Base);
if Is_Fixed_Point_Type (Parent_Type)
and then Nkind (Lo) = N_Real_Literal
and then Nkind (Hi) = N_Real_Literal
then
return;
else
Set_Etype (Rng, Implicit_Base);
Set_Analyzed (Rng, True);
end if;
end Convert_Scalar_Bounds;
procedure Copy_And_Swap (Privat, Full : Entity_Id) is
begin
Copy_Private_To_Full (Privat, Full);
Exchange_Entities (Privat, Full);
Append_Entity (Full, Scope (Full));
end Copy_And_Swap;
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_Finalize_Storage_Only (T1, Finalize_Storage_Only (T2));
Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (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;
procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
begin
Set_Size_Info (T1, T2);
Set_First_Index (T1, First_Index (T2));
Set_Is_Aliased (T1, Is_Aliased (T2));
Set_Is_Atomic (T1, Is_Atomic (T2));
Set_Is_Volatile (T1, Is_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));
end Copy_Array_Subtype_Attributes;
procedure Copy_Private_To_Full (Priv, Full : Entity_Id) is
begin
Set_Ekind (Full, Ekind (Priv));
Set_Etype (Full, Any_Type);
Set_Has_Discriminants (Full, Has_Discriminants (Priv));
if Has_Discriminants (Full) then
Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
Set_Girder_Constraint (Full, Girder_Constraint (Priv));
end if;
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));
Conditional_Delay (Full, Priv);
if Is_Tagged_Type (Full) then
Set_Primitive_Operations (Full, Primitive_Operations (Priv));
if Priv = Base_Type (Priv) then
Set_Class_Wide_Type (Full, Class_Wide_Type (Priv));
end if;
end if;
Set_Is_Volatile (Full, Is_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 (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;
end Copy_Private_To_Full;
procedure Create_Constrained_Components
(Subt : Entity_Id;
Decl_Node : Node_Id;
Typ : Entity_Id;
Constraints : Elist_Id)
is
Loc : constant Source_Ptr := Sloc (Subt);
Assoc_List : List_Id := New_List;
Comp_List : Elist_Id := New_Elmt_List;
Discr_Val : Elmt_Id;
Errors : Boolean;
New_C : Entity_Id;
Old_C : Entity_Id;
Is_Static : Boolean := True;
Parent_Type : constant Entity_Id := Etype (Typ);
procedure Collect_Fixed_Components (Typ : Entity_Id);
procedure Create_All_Components;
function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
function Is_Variant_Record (T : Entity_Id) return Boolean;
procedure Collect_Fixed_Components (Typ : Entity_Id) is
begin
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))));
Next_Elmt (Discr_Val);
Next_Discriminant (Old_C);
end loop;
if Is_Tagged_Type (Typ)
or else Has_Controlled_Component (Typ)
then
Old_C := First_Component (Typ);
while Present (Old_C) loop
if Chars ((Old_C)) = Name_uTag
or else Chars ((Old_C)) = Name_uParent
or else Chars ((Old_C)) = Name_uController
then
Append_Elmt (Old_C, Comp_List);
end if;
Next_Component (Old_C);
end loop;
end if;
end Collect_Fixed_Components;
procedure Create_All_Components is
Comp : Elmt_Id;
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
(Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
Set_Is_Public (New_C, Is_Public (Subt));
Next_Elmt (Comp);
end loop;
end Create_All_Components;
function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
New_Compon : Entity_Id := New_Copy (Old_Compon);
begin
Set_Parent (New_Compon, Parent (Old_Compon));
Set_Comes_From_Source (New_Compon, False);
Enter_Name (New_Compon);
return New_Compon;
end Create_Component;
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;
begin
pragma Assert (Subt /= Base_Type (Subt));
pragma Assert (Typ = Base_Type (Typ));
Set_First_Entity (Subt, Empty);
Set_Last_Entity (Subt, Empty);
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;
Next_Elmt (Discr_Val);
end loop;
New_Scope (Subt);
Old_C := First_Discriminant (Typ);
while Present (Old_C) loop
New_C := Create_Component (Old_C);
Set_Is_Public (New_C, Is_Public (Subt));
Next_Discriminant (Old_C);
end loop;
if Is_Static
and then Is_Variant_Record (Typ)
then
Collect_Fixed_Components (Typ);
Gather_Components (
Typ,
Component_List (Type_Definition (Parent (Typ))),
Governed_By => Assoc_List,
Into => Comp_List,
Report_Errors => Errors);
pragma Assert (not Errors);
Create_All_Components;
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);
Gather_Components (
Typ,
Component_List (Type_Definition (Parent (Parent_Type))),
Governed_By => Assoc_List,
Into => Comp_List,
Report_Errors => Errors);
pragma Assert (not Errors);
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
and then Chars (Old_C) /= Name_uController
then
Append_Elmt (Old_C, Comp_List);
end if;
Next_Component (Old_C);
end loop;
end if;
Create_All_Components;
else
Old_C := First_Component (Typ);
while Present (Old_C) loop
New_C := Create_Component (Old_C);
Set_Etype
(New_C,
Constrain_Component_Type
(Etype (Old_C), Subt, Decl_Node, Typ, Constraints));
Set_Is_Public (New_C, Is_Public (Subt));
Next_Component (Old_C);
end loop;
end if;
End_Scope;
end Create_Constrained_Components;
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;
begin
Check_Restriction (No_Fixed_Point, Def);
Implicit_Base :=
Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B');
Set_Etype (Implicit_Base, Implicit_Base);
Analyze_And_Resolve (Delta_Expr, Universal_Real);
Check_Delta_Expression (Delta_Expr);
Delta_Val := Expr_Value_R (Delta_Expr);
declare
Val : Ureal := Delta_Val;
begin
Scale_Val := Uint_0;
if Val < Ureal_1 then
while Val < Ureal_1 loop
Val := Val * Ureal_10;
Scale_Val := Scale_Val + 1;
end loop;
if Scale_Val > 18 then
Error_Msg_N ("scale exceeds maximum value of 18", Def);
Scale_Val := UI_From_Int (+18);
end if;
else
while Val > Ureal_1 loop
Val := Val / Ureal_10;
Scale_Val := Scale_Val - 1;
end loop;
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;
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;
Set_Delta_Value (Implicit_Base, Delta_Val);
Set_Scale_Value (Implicit_Base, Scale_Val);
Set_Small_Value (Implicit_Base, Delta_Val);
Analyze_And_Resolve (Digs_Expr, Any_Integer);
Check_Digits_Expression (Digs_Expr);
Digs_Val := Expr_Value (Digs_Expr);
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;
Set_Digits_Value (Implicit_Base, Digs_Val);
Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val;
Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val);
Init_Size_Align (Implicit_Base);
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);
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;
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);
if Low_Val < (-Bound_Val) then
Error_Msg_N
("range low bound too small for digits value", Low);
Low_Val := -Bound_Val;
end if;
if High_Val > Bound_Val then
Error_Msg_N
("range high bound too large for digits value", High);
High_Val := Bound_Val;
end if;
Set_Fixed_Range (T, Loc, Low_Val, High_Val);
end;
else
Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
end if;
end Decimal_Fixed_Point_Type_Declaration;
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;
New_Formal : Entity_Id;
Same_Subt : constant Boolean :=
Is_Scalar_Type (Parent_Type)
and then Subtypes_Statically_Compatible (Parent_Type, Derived_Type);
function Is_Private_Overriding return Boolean;
procedure Replace_Type (Id, New_Id : Entity_Id);
function Is_Private_Overriding return Boolean is
Prev : Entity_Id;
begin
Prev := Homonym (Parent_Subp);
while Present (Prev) loop
if Is_Dispatching_Operation (Parent_Subp)
and then Present (Prev)
and then 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
return True;
end if;
Prev := Homonym (Prev);
end loop;
return False;
end Is_Private_Overriding;
procedure Replace_Type (Id, New_Id : Entity_Id) is
Acc_Type : Entity_Id;
IR : Node_Id;
begin
if Ekind (Etype (Id)) = E_Anonymous_Access_Type then
declare
Desig_Typ : Entity_Id := Designated_Type (Etype (Id));
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;
if Base_Type (Desig_Typ) = Base_Type (Parent_Type) then
Acc_Type := New_Copy (Etype (Id));
Set_Etype (Acc_Type, Acc_Type);
Set_Scope (Acc_Type, New_Subp);
if Is_Array_Type (Desig_Typ)
and then not Is_Constrained (Desig_Typ)
then
Init_Size (Acc_Type, 2 * System_Address_Size);
else
Init_Size (Acc_Type, System_Address_Size);
end if;
Init_Alignment (Acc_Type);
Set_Directly_Designated_Type (Acc_Type, Derived_Type);
Set_Etype (New_Id, Acc_Type);
Set_Scope (New_Id, New_Subp);
IR := Make_Itype_Reference (Sloc (Parent (Derived_Type)));
Set_Itype (IR, Acc_Type);
Insert_After (Parent (Derived_Type), IR);
else
Set_Etype (New_Id, Etype (Id));
end if;
end;
elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type)
or else
(Ekind (Etype (Id)) = E_Record_Type_With_Private
and then Present (Full_View (Etype (Id)))
and then Base_Type (Full_View (Etype (Id))) =
Base_Type (Parent_Type))
then
if Etype (Id) = Parent_Type
and then Same_Subt
then
Set_Etype (New_Id, Derived_Type);
else
Set_Etype (New_Id, Base_Type (Derived_Type));
end if;
else
Set_Etype (New_Id, Etype (Id));
end if;
end Replace_Type;
begin
New_Subp :=
New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
Set_Ekind (New_Subp, Ekind (Parent_Subp));
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 Chars (Parent_Subp) = Name_Initialize
or else Chars (Parent_Subp) = Name_Adjust
or else Chars (Parent_Subp) = Name_Finalize
then
Set_Chars (New_Subp, Chars (Parent_Subp));
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_Chars (New_Subp, Chars (Parent_Subp));
else
Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
end if;
Set_Parent (New_Subp, Parent (Derived_Type));
Replace_Type (Parent_Subp, New_Subp);
Conditional_Delay (New_Subp, Parent_Subp);
Formal := First_Formal (Parent_Subp);
while Present (Formal) loop
New_Formal := New_Copy (Formal);
Set_Parent (New_Formal, Parent (Formal));
Append_Entity (New_Formal, New_Subp);
Replace_Type (Formal, New_Formal);
Next_Formal (Formal);
end loop;
if No (Actual_Subp) then
Set_Alias (New_Subp, Parent_Subp);
Set_Is_Intrinsic_Subprogram (New_Subp,
Is_Intrinsic_Subprogram (Parent_Subp));
else
Set_Alias (New_Subp, Actual_Subp);
end if;
if Is_Tagged_Type (Derived_Type) then
Set_Convention (New_Subp, Convention (Parent_Subp));
end if;
Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp));
if Ekind (Parent_Subp) = E_Procedure then
Set_Is_Valued_Procedure
(New_Subp, Is_Valued_Procedure (Parent_Subp));
end if;
New_Overloaded_Entity (New_Subp, Derived_Type);
if Present (Actual_Subp)
and then Is_Dispatching_Operation (Parent_Subp)
then
Set_Is_Dispatching_Operation (New_Subp);
if Present (DTC_Entity (Parent_Subp)) then
Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp));
Set_DT_Position (New_Subp, DT_Position (Parent_Subp));
end if;
end if;
Set_Has_Completion (New_Subp);
Set_Default_Expressions_Processed (New_Subp);
if Is_Generic_Type (Derived_Type)
and then not Is_Abstract (Derived_Type)
then
null;
elsif Is_Abstract (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 (New_Subp);
end if;
if Ekind (New_Subp) = E_Function then
Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
end if;
end Derive_Subprogram;
procedure Derive_Subprograms
(Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Generic_Actual : Entity_Id := Empty)
is
Op_List : Elist_Id := Collect_Primitive_Operations (Parent_Type);
Act_List : Elist_Id;
Act_Elmt : Elmt_Id;
Elmt : Elmt_Id;
Subp : Entity_Id;
New_Subp : Entity_Id := Empty;
Parent_Base : Entity_Id;
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;
Elmt := First_Elmt (Op_List);
if Present (Generic_Actual) then
Act_List := Collect_Primitive_Operations (Generic_Actual);
Act_Elmt := First_Elmt (Act_List);
else
Act_Elmt := No_Elmt;
end if;
while Present (Elmt) loop
Subp := Node (Elmt);
if Ekind (Subp) /= E_Enumeration_Literal then
if No (Generic_Actual) then
Derive_Subprogram
(New_Subp, Subp, Derived_Type, Parent_Base);
else
Derive_Subprogram (New_Subp, Subp,
Derived_Type, Parent_Base, Node (Act_Elmt));
Next_Elmt (Act_Elmt);
end if;
end if;
Next_Elmt (Elmt);
end loop;
end Derive_Subprograms;
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');
Lo : Node_Id;
Hi : Node_Id;
T : Entity_Id;
begin
T := Process_Subtype (Indic, N);
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)));
Set_Is_Character_Type (Implicit_Base, True);
Set_Has_Delayed_Freeze (Implicit_Base);
Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type));
Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
Set_Scalar_Range (Implicit_Base,
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi));
Conditional_Delay (Derived_Type, Parent_Type);
Set_Ekind (Derived_Type, E_Enumeration_Subtype);
Set_Etype (Derived_Type, Implicit_Base);
Set_Size_Info (Derived_Type, Parent_Type);
if Unknown_RM_Size (Derived_Type) then
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
end if;
Set_Is_Character_Type (Derived_Type, True);
if Nkind (Indic) /= N_Subtype_Indication then
Set_Scalar_Range (Derived_Type, Scalar_Range (Implicit_Base));
end if;
Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
Freeze_Before (N, Implicit_Base);
end Derived_Standard_Character;
procedure Derived_Type_Declaration
(T : Entity_Id;
N : Node_Id;
Is_Completion : Boolean)
is
Def : constant Node_Id := Type_Definition (N);
Indic : constant Node_Id := Subtype_Indication (Def);
Extension : constant Node_Id := Record_Extension_Part (Def);
Parent_Type : Entity_Id;
Parent_Scope : Entity_Id;
Taggd : Boolean;
begin
Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
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 T = Parent_Type
or else T = Etype (Parent_Type)
then
Error_Msg_N ("type cannot be used in its own definition", Indic);
end if;
Set_Ekind (T, Ekind (Parent_Type));
Set_Etype (T, Any_Type);
Set_Scalar_Range (T, Scalar_Range (Any_Type));
if Is_Tagged_Type (T) then
Set_Primitive_Operations (T, New_Elmt_List);
end if;
return;
elsif Is_Unchecked_Union (Parent_Type) then
Error_Msg_N ("cannot derive from Unchecked_Union type", N);
end if;
if Present (Discriminant_Specifications (N))
and then (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);
end if;
if Ada_83
and then Is_Derived_Type (Parent_Type)
and then In_Visible_Part (Scope (Parent_Type))
then
if 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 Ekind (Parent_Type) = E_Void
or else Ekind (Parent_Type) = E_Incomplete_Type
then
Error_Msg_N ("premature derivation of incomplete type", Indic);
return;
elsif (Is_Incomplete_Or_Private_Type (Parent_Type)
and then not Is_Generic_Type (Parent_Type)
and then not Is_Generic_Type (Root_Type (Parent_Type))
and then not Is_Generic_Actual_Type (Parent_Type))
or else Has_Private_Component (Parent_Type)
then
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
Error_Msg_N
("premature derivation of derived or private type", Indic);
Set_Error_Posted (T);
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))
then
Parent_Scope := Scope (T);
while Present (Parent_Scope)
and then Parent_Scope /= Standard_Standard
loop
if Parent_Scope = Scope (Parent_Type) then
Error_Msg_N
("premature derivation from type with tagged full view",
Indic);
end if;
Parent_Scope := Scope (Parent_Scope);
end loop;
end if;
end if;
Taggd := Is_Tagged_Type (Parent_Type);
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 Present (Extension) and then not Taggd then
Error_Msg_N
("type derived from untagged type cannot have extension", Indic);
elsif No (Extension) and then Taggd then
if not Is_Generic_Actual_Type (Parent_Type)
or else In_Visible_Part (Scope (Parent_Type))
then
Error_Msg_N
("type derived from tagged type must have extension", Indic);
end if;
end if;
Build_Derived_Type (N, Parent_Type, T, Is_Completion);
end Derived_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;
begin
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);
R_Node := New_Node (N_Range, Sloc (Def));
Set_Low_Bound (R_Node, B_Node);
Set_Ekind (T, E_Enumeration_Type);
Set_First_Literal (T, L);
Set_Etype (T, T);
Set_Is_Constrained (T);
Ev := Uint_0;
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;
Set_Etype (L, T);
New_Overloaded_Entity (L);
Generate_Definition (L);
Set_Convention (L, Convention_Intrinsic);
if Nkind (L) = N_Defining_Character_Literal then
Set_Is_Character_Type (T, True);
end if;
Ev := Ev + 1;
Next (L);
end loop;
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);
Set_High_Bound (R_Node, B_Node);
Set_Scalar_Range (T, R_Node);
Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
Set_Enum_Esize (T);
if Global_Discard_Names
or else Discard_Names (Scope (T))
then
Set_Discard_Names (T);
end if;
if Present (Def) then
Process_End_Label (Def, 'e', T);
end if;
end Enumeration_Type_Declaration;
procedure Expand_Others_Choice
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
Choice_Type : Entity_Id)
is
Choice : Node_Id;
Choice_List : List_Id := New_List;
Exp_Lo : Node_Id;
Exp_Hi : Node_Id;
Hi : Uint;
Lo : Uint;
Loc : Source_Ptr := Sloc (Others_Choice);
Previous_Hi : Uint;
function Build_Choice (Value1, Value2 : Uint) return Node_Id;
function Lit_Of (Value : Uint) return Node_Id;
function Build_Choice (Value1, Value2 : Uint) return Node_Id is
Lit_Node : Node_Id;
Lo, Hi : Node_Id;
begin
if (Value2 - Value1) = 0 then
if Is_Integer_Type (Choice_Type) then
Lit_Node := Make_Integer_Literal (Loc, Value1);
Set_Etype (Lit_Node, Choice_Type);
else
Lit_Node := Lit_Of (Value1);
end if;
else
if Is_Integer_Type (Choice_Type) then
Lo := Make_Integer_Literal (Loc, Value1);
Set_Etype (Lo, Choice_Type);
Hi := Make_Integer_Literal (Loc, Value2);
Set_Etype (Hi, Choice_Type);
Lit_Node :=
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi);
else
Lit_Node :=
Make_Range (Loc,
Low_Bound => Lit_Of (Value1),
High_Bound => Lit_Of (Value2));
end if;
end if;
return Lit_Node;
end Build_Choice;
function Lit_Of (Value : Uint) return Node_Id is
Lit : Entity_Id;
begin
if Root_Type (Choice_Type) = Standard_Character then
Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
Lit := New_Node (N_Character_Literal, Loc);
Set_Chars (Lit, Name_Find);
Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value)));
Set_Etype (Lit, Choice_Type);
Set_Is_Static_Expression (Lit, True);
return Lit;
else
Lit := First_Literal (Choice_Type);
for J in 1 .. UI_To_Int (Value) loop
Next_Literal (Lit);
end loop;
return New_Occurrence_Of (Lit, Loc);
end if;
end Lit_Of;
begin
if Case_Table'Length = 0 then
if Is_Static_Subtype (Choice_Type) then
Choice := New_Occurrence_Of (Choice_Type, Loc);
else
Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
end if;
Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
return;
end if;
if Is_OK_Static_Subtype (Choice_Type) then
Exp_Lo := Type_Low_Bound (Choice_Type);
Exp_Hi := Type_High_Bound (Choice_Type);
else
Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
end if;
Lo := Expr_Value (Case_Table (Case_Table'First).Lo);
Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
if Expr_Value (Exp_Lo) < Lo then
Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
end if;
for J in Case_Table'First + 1 .. Case_Table'Last loop
Lo := Expr_Value (Case_Table (J).Lo);
Hi := Expr_Value (Case_Table (J).Hi);
if Lo /= (Previous_Hi + 1) then
Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
end if;
Previous_Hi := Hi;
end loop;
if Expr_Value (Exp_Hi) > Hi then
Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
end if;
Set_Others_Discrete_Choices (Others_Choice, Choice_List);
end Expand_Others_Choice;
function Expand_To_Girder_Constraint
(Typ : Entity_Id;
Constraint : Elist_Id)
return Elist_Id
is
Explicitly_Discriminated_Type : Entity_Id;
Expansion : Elist_Id;
Discriminant : Entity_Id;
function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id;
function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is
Typ : constant E := Base_Type (Id);
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
if Has_Discriminants (Typ) then
return Typ;
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;
begin
if No (Constraint)
or else Is_Empty_Elmt_List (Constraint)
then
return No_Elist;
end if;
Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ);
if No (Explicitly_Discriminated_Type) then
return No_Elist;
end if;
Expansion := New_Elmt_List;
Discriminant :=
First_Girder_Discriminant (Explicitly_Discriminated_Type);
while Present (Discriminant) loop
Append_Elmt (
Get_Discriminant_Value (
Discriminant, Explicitly_Discriminated_Type, Constraint),
Expansion);
Next_Girder_Discriminant (Discriminant);
end loop;
return Expansion;
end Expand_To_Girder_Constraint;
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;
begin
Prev := Current_Entity_In_Scope (Id);
if Present (Prev) then
Prev_Par := Parent (Prev);
if not Is_Incomplete_Or_Private_Type (Prev) then
Enter_Name (Id);
New_Id := Id;
elsif Nkind (N) /= N_Full_Type_Declaration
and then Nkind (N) /= N_Task_Type_Declaration
and then Nkind (N) /= N_Protected_Type_Declaration
then
Error_Msg_Sloc := Sloc (Prev);
Error_Msg_NE ("invalid completion of }", Id, Prev);
Set_Scope (Id, Current_Scope);
New_Id := Id;
elsif Ekind (Prev) = E_Incomplete_Type then
if Present (Full_View (Prev)) then
Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
end if;
Set_Full_View (Prev, Id);
Append_Entity (Id, Current_Scope);
Set_Is_Public (Id, Is_Public (Prev));
Set_Is_Internal (Id);
New_Id := Prev;
else
if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then
if Etype (Prev) /= Prev then
Error_Msg_NE ("invalid redeclaration of }", Id, Prev);
New_Id := Id;
elsif Ekind (Prev) = E_Private_Type
and then
(Nkind (N) = N_Task_Type_Declaration
or else Nkind (N) = N_Protected_Type_Declaration)
then
Error_Msg_N
("completion of nonlimited type cannot be limited", N);
end if;
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);
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;
if not In_Private_Part (Current_Scope) then
Error_Msg_N
("declaration of full view must appear in private part", N);
end if;
Copy_And_Swap (Prev, Id);
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
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;
Set_Full_View (Id, Prev);
New_Id := Prev;
end if;
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;
else
Error_Msg_N
("missing discriminants in full type declaration", N);
Set_Discriminant_Specifications (N,
Discriminant_Specifications (Prev_Par));
end if;
end if;
if Is_Type (Prev)
and then (Is_Tagged_Type (Prev)
or else Present (Class_Wide_Type (Prev)))
then
if Nkind (Type_Definition (N)) = N_Record_Definition then
if not Tagged_Present (Type_Definition (N)) then
Error_Msg_NE
("full declaration of } must be tagged", Prev, Id);
Set_Is_Tagged_Type (Id);
Set_Primitive_Operations (Id, New_Elmt_List);
end if;
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);
Set_Is_Tagged_Type (Id);
Set_Primitive_Operations (Id, New_Elmt_List);
end if;
else
Error_Msg_NE
("full declaration of } must be a tagged type", Prev, Id);
end if;
end if;
return New_Id;
else
Enter_Name (Id);
return Id;
end if;
end Find_Type_Name;
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 : constant Node_Id := Parent (Obj_Def);
T : Entity_Id;
Nam : Name_Id;
begin
if Def_Kind = N_Constrained_Array_Definition
or else Def_Kind = N_Unconstrained_Array_Definition
then
T := Empty;
Array_Type_Declaration (T, Obj_Def);
elsif Nkind (P) /= N_Component_Declaration
and then Def_Kind = N_Subtype_Indication
then
if Error_Posted (P) then
Analyze (Subtype_Mark (Obj_Def));
return Entity (Subtype_Mark (Obj_Def));
end if;
Nam :=
New_External_Name
(Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T');
T := Make_Defining_Identifier (Sloc (P), Nam);
Insert_Action (Obj_Def,
Make_Subtype_Declaration (Sloc (P),
Defining_Identifier => T,
Subtype_Indication => Relocate_Node (Obj_Def)));
if Nkind (P) = N_Object_Declaration
and then Constant_Present (P)
and then No (Expression (P))
then
null;
else
Insert_Actions (Obj_Def, Freeze_Entity (T, Sloc (P)));
end if;
else
T := Process_Subtype (Obj_Def, Related_Nod);
end if;
return T;
end Find_Type_Of_Object;
function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is
Typ : Entity_Id;
begin
if Nkind (S) = N_Subtype_Indication then
Find_Type (Subtype_Mark (S));
Typ := Entity (Subtype_Mark (S));
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;
elsif Error_Posted (S) then
Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
return Any_Type;
else
Find_Type (S);
Typ := Entity (S);
end if;
if Typ = Standard_Wide_Character
or else Typ = Standard_Wide_String
then
Check_Restriction (No_Wide_Characters, S);
end if;
return Typ;
end Find_Type_Of_Subtype_Indic;
procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is
Digs : constant Node_Id := Digits_Expression (Def);
Digs_Val : Uint;
Base_Typ : Entity_Id;
Implicit_Base : Entity_Id;
Bound : Node_Id;
function Can_Derive_From (E : Entity_Id) return Boolean;
function Can_Derive_From (E : Entity_Id) return Boolean is
Spec : constant Entity_Id := Real_Range_Specification (Def);
begin
if Digs_Val > Digits_Value (E) then
return False;
end if;
if Present (Spec) then
if Expr_Value_R (Type_Low_Bound (E)) >
Expr_Value_R (Low_Bound (Spec))
then
return False;
end if;
if Expr_Value_R (Type_High_Bound (E)) <
Expr_Value_R (High_Bound (Spec))
then
return False;
end if;
end if;
return True;
end Can_Derive_From;
begin
Check_Restriction (No_Floating_Point, Def);
Implicit_Base :=
Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B');
Analyze_And_Resolve (Digs, Any_Integer);
Check_Digits_Expression (Digs);
Digs_Val := Expr_Value (Digs);
Process_Real_Range_Specification (Def);
if Can_Derive_From (Standard_Short_Float) then
Base_Typ := Standard_Short_Float;
elsif Can_Derive_From (Standard_Float) then
Base_Typ := Standard_Float;
elsif Can_Derive_From (Standard_Long_Float) then
Base_Typ := Standard_Long_Float;
elsif Can_Derive_From (Standard_Long_Long_Float) then
Base_Typ := Standard_Long_Long_Float;
else
Base_Typ := Standard_Long_Long_Float;
if Digs_Val >= Digits_Value (Standard_Long_Long_Float) then
Error_Msg_Uint_1 := Digits_Value (Standard_Long_Long_Float);
Error_Msg_N ("digits value out of range, maximum is ^", Digs);
else
Error_Msg_N
("range too large for any predefined type",
Real_Range_Specification (Def));
end if;
end if;
if Present (Real_Range_Specification (Def)) then
Set_Scalar_Range (T, Real_Range_Specification (Def));
Set_Is_Constrained (T);
Bound := Type_Low_Bound (T);
if Nkind (Bound) = N_Real_Literal then
Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
Set_Is_Machine_Number (Bound);
end if;
Bound := Type_High_Bound (T);
if Nkind (Bound) = N_Real_Literal then
Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
Set_Is_Machine_Number (Bound);
end if;
else
Set_Scalar_Range (T, Scalar_Range (Base_Typ));
end if;
Set_Etype (Implicit_Base, Base_Typ);
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_Vax_Float (Implicit_Base, Vax_Float (Base_Typ));
Set_Ekind (T, E_Floating_Point_Subtype);
Set_Etype (T, Implicit_Base);
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;
function Get_Discriminant_Value
(Discriminant : Entity_Id;
Typ_For_Constraint : Entity_Id;
Constraint : Elist_Id)
return Node_Id
is
function Recurse
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
Girder_Discrim_Values : Boolean)
return Node_Or_Entity_Id;
function Recurse
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
Girder_Discrim_Values : Boolean)
return Node_Or_Entity_Id
is
Assoc : Elmt_Id;
Disc : Entity_Id;
Result : Node_Or_Entity_Id;
Result_Entity : Node_Id;
begin
if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then
return Error;
end if;
if not Girder_Discrim_Values
and then Present (Girder_Constraint (Ti))
and then not Is_Tagged_Type (Ti)
then
Result := Recurse (Ti, Girder_Constraint (Ti), True);
else
declare
Td : Entity_Id := Etype (Ti);
begin
if Td = Ti then
Result := Discriminant;
else
if Present (Girder_Constraint (Ti)) then
Result :=
Recurse (Td, Girder_Constraint (Ti), True);
else
Result :=
Recurse (Td, Discrim_Values, Girder_Discrim_Values);
end if;
end if;
end;
end if;
if Result = Discriminant then
if Is_Concurrent_Type (Ti)
and then Present (Corresponding_Record_Type (Ti))
then
Result :=
Recurse (
Corresponding_Record_Type (Ti),
Discrim_Values,
Girder_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 :=
Recurse (
Full_View (Ti),
Discrim_Values,
Girder_Discrim_Values);
end if;
end if;
if Nkind (Result) = N_Defining_Identifier then
pragma Assert (Result = Discriminant);
Result_Entity := Result;
else
if not Denotes_Discriminant (Result) then
return Result;
end if;
Result_Entity := Entity (Result);
end if;
if not Has_Discriminants (Ti) then
return Result;
end if;
Result_Entity := Original_Record_Component (Result_Entity);
Assoc := First_Elmt (Discrim_Values);
if Girder_Discrim_Values then
Disc := First_Girder_Discriminant (Ti);
else
Disc := First_Discriminant (Ti);
end if;
while Present (Disc) loop
pragma Assert (Present (Assoc));
if Original_Record_Component (Disc) = Result_Entity then
return Node (Assoc);
end if;
Next_Elmt (Assoc);
if Girder_Discrim_Values then
Next_Girder_Discriminant (Disc);
else
Next_Discriminant (Disc);
end if;
end loop;
return Result;
end Recurse;
Result : Node_Or_Entity_Id;
begin
if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
declare
D : Entity_Id := First_Discriminant (Typ_For_Constraint);
E : Elmt_Id := First_Elmt (Constraint);
begin
while Present (D) loop
if Chars (D) = Chars (Discriminant) then
return Node (E);
end if;
Next_Discriminant (D);
Next_Elmt (E);
end loop;
end;
end if;
Result := Recurse (Typ_For_Constraint, Constraint, False);
if Nkind (Result) = N_Defining_Identifier then
declare
D : Entity_Id := First_Discriminant (Typ_For_Constraint);
E : Elmt_Id := First_Elmt (Constraint);
begin
while Present (D) loop
if Corresponding_Discriminant (D) = Discriminant then
return Node (E);
end if;
Next_Discriminant (D);
Next_Elmt (E);
end loop;
end;
end if;
pragma Assert (Nkind (Result) /= N_Defining_Identifier);
return Result;
end Get_Discriminant_Value;
function Has_Range_Constraint (N : Node_Id) return Boolean is
C : constant Node_Id := Constraint (N);
begin
if Nkind (C) = N_Range_Constraint then
return True;
elsif Nkind (C) = N_Digits_Constraint then
return
Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
or else
Present (Range_Constraint (C));
elsif Nkind (C) = N_Delta_Constraint then
return Present (Range_Constraint (C));
else
return False;
end if;
end Has_Range_Constraint;
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 : Elist_Id := New_Elmt_List;
procedure Inherit_Component
(Old_C : Entity_Id;
Plain_Discrim : Boolean := False;
Girder_Discrim : Boolean := False);
procedure Inherit_Component
(Old_C : Entity_Id;
Plain_Discrim : Boolean := False;
Girder_Discrim : Boolean := False)
is
New_C : Entity_Id := New_Copy (Old_C);
Discrim : Entity_Id;
Corr_Discrim : Entity_Id;
begin
pragma Assert (not Is_Tagged or else not Girder_Discrim);
Set_Parent (New_C, Parent (Old_C));
if not Girder_Discrim then
Enter_Name (New_C);
end if;
if not Is_Tagged then
Set_Original_Record_Component (New_C, New_C);
end if;
if Ekind (New_C) = E_Component then
if (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));
else
Set_Etype (New_C, Constrain_Component_Type (Etype (Old_C),
Derived_Base, N, Parent_Base, Discs));
end if;
end if;
if Is_Tagged and then Ekind (New_C) = E_Component then
Set_Ekind (New_C, E_Void);
end if;
if Plain_Discrim then
Set_Corresponding_Discriminant (New_C, Old_C);
Build_Discriminal (New_C);
elsif Girder_Discrim then
Set_Corresponding_Discriminant (New_C, Empty);
Set_Discriminal (New_C, Empty);
Set_Is_Completely_Hidden (New_C);
Discrim := First_Discriminant (Derived_Base);
while Present (Discrim) loop
Corr_Discrim := Corresponding_Discriminant (Discrim);
if Present (Corr_Discrim)
and then Original_Record_Component (Corr_Discrim) = Old_C
then
Set_Original_Record_Component (Discrim, New_C);
end if;
Next_Discriminant (Discrim);
end loop;
Append_Entity (New_C, Derived_Base);
end if;
if not Is_Tagged then
Append_Elmt (Old_C, Assoc_List);
Append_Elmt (New_C, Assoc_List);
end if;
end Inherit_Component;
Loc : constant Source_Ptr := Sloc (N);
Parent_Discrim : Entity_Id;
Girder_Discrim : Entity_Id;
D : Entity_Id;
Component : Entity_Id;
begin
if not Is_Tagged then
Append_Elmt (Parent_Base, Assoc_List);
Append_Elmt (Derived_Base, Assoc_List);
end if;
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 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_Girder_Discriminant (Parent_Base))
then
Girder_Discrim := First_Girder_Discriminant (Parent_Base);
while Present (Girder_Discrim) loop
Inherit_Component (Girder_Discrim, Girder_Discrim => True);
Next_Girder_Discriminant (Girder_Discrim);
end loop;
end if;
if Inherit_Discr
and then Is_Empty_Elmt_List (Discs)
and then (not Is_Private_Type (Derived_Base)
or Is_Generic_Type (Derived_Base))
then
D := First_Discriminant (Derived_Base);
while Present (D) loop
Append_Elmt (New_Reference_To (D, Loc), Discs);
Next_Discriminant (D);
end loop;
end if;
Component := First_Entity (Parent_Base);
while Present (Component) loop
if Ekind (Component) /= E_Component
or else Chars (Component) = Name_uParent
then
null;
elsif not Is_Visible_Component (Component)
and then not In_Open_Scopes (Scope (Parent_Base))
then
null;
elsif Ekind (Derived_Base) = E_Private_Type
or else Ekind (Derived_Base) = E_Limited_Private_Type
then
null;
else
Inherit_Component (Component);
end if;
Next_Entity (Component);
end loop;
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;
return Assoc_List;
end Inherit_Components;
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;
when Decimal_Fixed_Point_Kind =>
return
Constraint_Kind = N_Digits_Constraint
or else
Constraint_Kind = N_Range_Constraint;
when Ordinary_Fixed_Point_Kind =>
return
Constraint_Kind = N_Delta_Constraint
or else
Constraint_Kind = N_Range_Constraint;
when Float_Kind =>
return
Constraint_Kind = N_Digits_Constraint
or else
Constraint_Kind = N_Range_Constraint;
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;
when others =>
return True; end case;
end Is_Valid_Constraint_Kind;
function Is_Visible_Component (C : Entity_Id) return Boolean is
Original_Comp : constant Entity_Id := Original_Record_Component (C);
Original_Scope : Entity_Id;
begin
if No (Original_Comp) then
return False;
else
Original_Scope := Scope (Original_Comp);
end if;
if not Is_Tagged_Type (Original_Scope) then
return True;
elsif not Comes_From_Source (Original_Comp) then
return True;
elsif In_Instance_Body then
return True;
elsif Ekind (Original_Comp) = E_Discriminant
and then not Has_Unknown_Discriminants (Original_Scope)
then
return True;
elsif (Ekind (Original_Comp) /= E_Discriminant
or else Has_Unknown_Discriminants (Original_Scope))
and then
(Is_Private_Type (Original_Scope)
or else
(not Is_Private_Descendant (Scope (Base_Type (Scope (C))))
and then not In_Open_Scopes (Scope (Base_Type (Scope (C))))
and then Has_Private_Declaration (Original_Scope)))
then
return False;
else
declare
Ancestor : Entity_Id := Scope (C);
begin
loop
if Ancestor = Original_Scope then
return True;
elsif Ancestor = Etype (Ancestor) then
return False;
end if;
Ancestor := Etype (Ancestor);
end loop;
return True;
end;
end if;
end Is_Visible_Component;
procedure Make_Class_Wide_Type (T : Entity_Id) is
CW_Type : Entity_Id;
CW_Name : Name_Id;
Next_E : Entity_Id;
begin
if Present (Class_Wide_Type (T)) then
return;
end if;
CW_Type :=
New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T');
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_Has_Delayed_Freeze (CW_Type);
Set_Ekind (CW_Type, E_Class_Wide_Type);
Set_Is_Tagged_Type (CW_Type, True);
Set_Primitive_Operations (CW_Type, New_Elmt_List);
Set_Is_Abstract (CW_Type, False);
Set_Is_Constrained (CW_Type, False);
Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
Init_Size_Align (CW_Type);
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_Has_Discriminants (CW_Type,
Has_Discriminants (T) and then not Is_Constrained (T));
Set_Has_Unknown_Discriminants (CW_Type, True);
Set_Class_Wide_Type (T, CW_Type);
Set_Equivalent_Type (CW_Type, Empty);
Set_Class_Wide_Type (CW_Type, CW_Type);
end Make_Class_Wide_Type;
procedure Make_Index
(I : Node_Id;
Related_Nod : Node_Id;
Related_Id : Entity_Id := Empty;
Suffix_Index : Nat := 1)
is
R : Node_Id;
T : Entity_Id;
Def_Id : Entity_Id := Empty;
Found : Boolean := False;
begin
if Nkind (I) = N_Range then
if not Is_Overloaded (I) then
T := Etype (I);
if T = Universal_Integer then
T := Standard_Integer;
elsif T = Any_Character then
if not Ada_83 then
Error_Msg_N
("ambiguous character literals (could be Wide_Character)",
I);
end if;
T := Standard_Character;
end if;
else
T := Any_Type;
declare
Ind : Interp_Index;
It : Interp;
begin
Get_First_Interp (I, 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", I);
exit;
else
T := It.Typ;
Found := True;
end if;
end if;
Get_Next_Interp (Ind, It);
end loop;
if T = Any_Type then
Error_Msg_N ("discrete type required for range", I);
Set_Etype (I, Any_Type);
return;
elsif T = Universal_Integer then
T := Standard_Integer;
end if;
end;
end if;
if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", I);
Set_Etype (I, Any_Type);
return;
end if;
R := I;
Process_Range_Expr_In_Decl (R, T);
elsif Nkind (I) = N_Subtype_Indication then
T := Base_Type (Entity (Subtype_Mark (I)));
if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", I);
Set_Etype (I, Any_Type);
return;
end if;
R := Range_Expression (Constraint (I));
Resolve (R, T);
Process_Range_Expr_In_Decl (R, Entity (Subtype_Mark (I)));
elsif Nkind (I) = N_Attribute_Reference then
Analyze_And_Resolve (I);
T := Etype (I);
R := I;
else
if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then
Error_Msg_N ("invalid subtype mark in discrete range ", I);
Set_Etype (I, Any_Integer);
return;
else
Set_Entity (I, Get_Full_View (Entity (I)));
Set_Etype (I, Entity (I));
Def_Id := Entity (I);
if not Is_Discrete_Type (Def_Id) then
Error_Msg_N ("discrete type required for index", I);
Set_Etype (I, Any_Type);
return;
end if;
end if;
if Expander_Active then
Rewrite (I,
Make_Attribute_Reference (Sloc (I),
Attribute_Name => Name_Range,
Prefix => Relocate_Node (I)));
Set_Must_Not_Freeze (I);
Set_Must_Not_Freeze (Prefix (I));
Analyze (I);
T := Etype (I);
Resolve (I, T);
R := I;
else
return;
end if;
end if;
if not Is_Discrete_Type (T) then
Error_Msg_N ("discrete type required for range", I);
Set_Etype (I, Any_Type);
return;
elsif T = Any_Type then
Set_Etype (I, Any_Type);
return;
end if;
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));
if Is_Signed_Integer_Type (T) then
Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
elsif Is_Modular_Integer_Type (T) then
Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
else
Set_Ekind (Def_Id, E_Enumeration_Subtype);
Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
end if;
Set_Size_Info (Def_Id, (T));
Set_RM_Size (Def_Id, RM_Size (T));
Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
Set_Scalar_Range (Def_Id, R);
Conditional_Delay (Def_Id, T);
if Nkind (I) = N_Subtype_Indication
and then not Is_Static_Subtype (Entity (Subtype_Mark (I)))
then
Set_Is_Non_Static_Subtype (Def_Id);
end if;
end if;
Set_Etype (I, Def_Id);
end Make_Index;
procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is
Mod_Expr : constant Node_Id := Expression (Def);
M_Val : Uint;
procedure Set_Modular_Size (Bits : Int);
procedure Set_Modular_Size (Bits : Int) is
begin
Set_RM_Size (T, UI_From_Int (Bits));
if Bits <= 8 then
Init_Esize (T, 8);
elsif Bits <= 16 then
Init_Esize (T, 16);
elsif Bits <= 32 then
Init_Esize (T, 32);
else
Init_Esize (T, System_Max_Binary_Modulus_Power);
end if;
end Set_Modular_Size;
begin
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
Error_Msg_N
("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;
Set_Modulus (T, M_Val);
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)));
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)));
for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop
if M_Val = 2 ** Bits then
Set_Modular_Size (Bits);
return;
elsif M_Val < 2 ** Bits then
Set_Non_Binary_Modulus (T);
if Bits > System_Max_Nonbinary_Modulus_Power then
Error_Msg_Uint_1 :=
UI_From_Int (System_Max_Nonbinary_Modulus_Power);
Error_Msg_N
("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
Set_Modular_Size (System_Max_Binary_Modulus_Power);
return;
else
Set_Modular_Size (Bits);
return;
end if;
end if;
end loop;
Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
Error_Msg_N ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
Set_Modular_Size (System_Max_Binary_Modulus_Power);
Init_Alignment (T);
end Modular_Type_Declaration;
procedure New_Binary_Operator (Op_Name : Name_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Op : Entity_Id;
function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id;
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;
begin
Op := Make_Defining_Operator_Symbol (Loc, Op_Name);
Set_Ekind (Op, E_Operator);
Set_Scope (Op, Current_Scope);
Set_Etype (Op, Typ);
Set_Homonym (Op, Get_Name_Entity_Id (Op_Name));
Set_Is_Immediately_Visible (Op);
Set_Is_Intrinsic_Subprogram (Op);
Set_Has_Completion (Op);
Append_Entity (Op, Current_Scope);
Set_Name_Entity_Id (Op_Name, Op);
Append_Entity (Make_Op_Formal (Typ, Op), Op);
Append_Entity (Make_Op_Formal (Typ, Op), Op);
end New_Binary_Operator;
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;
begin
Check_Restriction (No_Fixed_Point, Def);
Implicit_Base :=
Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B');
Set_Etype (Implicit_Base, Implicit_Base);
Analyze_And_Resolve (Delta_Expr, Any_Real);
Check_Delta_Expression (Delta_Expr);
Delta_Val := Expr_Value_R (Delta_Expr);
Set_Delta_Value (Implicit_Base, Delta_Val);
declare
Tmp : Ureal := Ureal_1;
Scale : Int := 0;
begin
if Delta_Val < Ureal_1 then
while Delta_Val < Tmp loop
Tmp := Tmp / Ureal_2;
Scale := Scale + 1;
end loop;
else
loop
Tmp := Tmp * Ureal_2;
exit when Tmp > Delta_Val;
Scale := Scale - 1;
end loop;
end if;
Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2);
end;
Set_Small_Value (Implicit_Base, Small_Val);
if RRS <= Empty_Or_Error then
Low_Val := -Small_Val;
High_Val := Small_Val;
else
declare
Low : constant Node_Id := Low_Bound (RRS);
High : constant Node_Id := High_Bound (RRS);
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);
if Low_Val > High_Val then
Error_Msg_NE ("?fixed point type& has null range", Def, T);
end if;
end;
end if;
Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
Set_Fixed_Range (T, Loc, Low_Val, High_Val);
Init_Size_Align (Implicit_Base);
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;
procedure Prepare_Private_Subtype_Completion
(Id : Entity_Id;
Related_Nod : Node_Id)
is
Id_B : constant Entity_Id := Base_Type (Id);
Full_B : constant Entity_Id := Full_View (Id_B);
Full : Entity_Id;
begin
if Present (Full_B) then
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;
if Is_Private_Type (Id_B) then
Append_Elmt (Id, Private_Dependents (Id_B));
end if;
end Prepare_Private_Subtype_Completion;
procedure Process_Discriminants (N : Node_Id) is
Id : Node_Id;
Discr : Node_Id;
Discr_Number : Uint;
Discr_Type : Entity_Id;
Default_Present : Boolean := False;
Default_Not_Present : Boolean := False;
Elist : Elist_Id := New_Elmt_List;
begin
Discr := First (Discriminant_Specifications (N));
while Present (Discr) loop
Enter_Name (Defining_Identifier (Discr));
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
else
Find_Type (Discriminant_Type (Discr));
Discr_Type := Etype (Discriminant_Type (Discr));
if Error_Posted (Discriminant_Type (Discr)) then
Discr_Type := Any_Type;
end if;
end if;
if Is_Access_Type (Discr_Type) then
Check_Access_Discriminant_Requires_Limited
(Discr, Discriminant_Type (Discr));
if Ada_83 and then Comes_From_Source (Discr) then
Error_Msg_N
("(Ada 83) access discriminant not allowed", Discr);
end if;
elsif not Is_Discrete_Type (Discr_Type) then
Error_Msg_N ("discriminants must have a discrete or access type",
Discriminant_Type (Discr));
end if;
Set_Etype (Defining_Identifier (Discr), Discr_Type);
if Present (Expression (Discr)) then
Analyze_Default_Expression (Expression (Discr), Discr_Type);
if Nkind (N) = N_Formal_Type_Declaration then
Error_Msg_N
("discriminant defaults not allowed for formal type",
Expression (Discr));
elsif Is_Tagged_Type (Current_Scope) then
Error_Msg_N
("discriminants of tagged type cannot have defaults",
Expression (Discr));
else
Default_Present := True;
Append_Elmt (Expression (Discr), Elist);
Set_Discriminant_Default_Value
(Defining_Identifier (Discr), Expression (Discr));
end if;
else
Default_Not_Present := True;
end if;
Next (Discr);
end loop;
Set_Discriminant_Constraint (Current_Scope, Elist);
Set_Girder_Constraint (Current_Scope, No_Elist);
if Default_Present and then Default_Not_Present then
Error_Msg_N
("incomplete specification of defaults for discriminants", N);
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);
Set_Corresponding_Discriminant (Id, Empty);
Set_Original_Record_Component (Id, Id);
Build_Discriminal (Id);
Next (Discr);
Discr_Number := Discr_Number + 1;
end loop;
Set_Has_Discriminants (Current_Scope);
end Process_Discriminants;
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;
begin
if not Is_Limited_Type (Priv_T)
and then (Is_Limited_Type (Full_T)
or else Is_Limited_Composite (Full_T))
then
Error_Msg_N
("completion of nonlimited type cannot be limited", Full_T);
elsif Is_Abstract (Full_T) and then not Is_Abstract (Priv_T) then
Error_Msg_N
("completion of nonabstract type cannot be abstract", Full_T);
elsif Is_Tagged_Type (Priv_T)
and then Is_Limited_Type (Priv_T)
and then not Is_Limited_Type (Full_T)
then
if Etype (Full_T) = Full_View (RTE (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 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 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 Priv_Parent = Any_Type or else Full_Parent = Any_Type then
return;
elsif 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);
elsif not Present (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));
Priv_Constr : constant Boolean :=
Is_Constrained (Priv_Parent)
or else
Nkind (Priv_Indic) = N_Subtype_Indication
or else Is_Constrained (Entity (Priv_Indic));
Full_Constr : constant Boolean :=
Is_Constrained (Full_Parent)
or else
Nkind (Full_Indic) = N_Subtype_Indication
or else Is_Constrained (Entity (Full_Indic));
Priv_Discr : Entity_Id;
Full_Discr : Entity_Id;
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;
Next_Discriminant (Priv_Discr);
Next_Discriminant (Full_Discr);
end loop;
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);
elsif Priv_Constr and then not Full_Constr then
Error_Msg_N
("parent subtype of full type must be constrained",
Full_Indic);
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;
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;
else
if not Is_Indefinite_Subtype (Priv_T)
and then Is_Indefinite_Subtype (Full_T)
then
Error_Msg_N ("full view of type must be definite subtype", Full_T);
end if;
end if;
declare
Priv_Elmt : Elmt_Id;
Priv : Entity_Id;
Full : Entity_Id;
begin
Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
while Present (Priv_Elmt) loop
Priv := Node (Priv_Elmt);
if Ekind (Priv) = E_Private_Subtype
or else Ekind (Priv) = E_Limited_Private_Subtype
or else Ekind (Priv) = 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);
Copy_And_Swap (Priv, Full);
Complete_Private_Subtype (Full, Priv, Full_T, N);
Replace_Elmt (Priv_Elmt, Full);
end if;
Next_Elmt (Priv_Elmt);
end loop;
end;
if Is_Tagged_Type (Full_T) then
declare
Priv_List : Elist_Id;
Full_List : constant Elist_Id := Primitive_Operations (Full_T);
P1, P2 : Elmt_Id;
Prim : Entity_Id;
D_Type : Entity_Id;
begin
if Is_Tagged_Type (Priv_T) then
Priv_List := Primitive_Operations (Priv_T);
P1 := First_Elmt (Priv_List);
while Present (P1) loop
Prim := Node (P1);
if Comes_From_Source (Prim) then
P2 := First_Elmt (Full_List);
while Present (P2) and then Node (P2) /= Prim loop
Next_Elmt (P2);
end loop;
if No (P2) then
Append_Elmt (Prim, Full_List);
end if;
end if;
Next_Elmt (P1);
end loop;
else
Prim := Next_Entity (Full_T);
while Present (Prim) and then Prim /= Priv_T loop
if (Ekind (Prim) = E_Procedure
or else Ekind (Prim) = E_Function)
then
D_Type := Find_Dispatching_Type (Prim);
if D_Type = 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;
elsif Is_Dispatching_Operation (Prim)
and then D_Type /= Full_T
then
Check_Controlling_Formals (D_Type, Prim);
end if;
end if;
Next_Entity (Prim);
end loop;
end if;
if Is_Tagged_Type (Priv_T) then
Set_Primitive_Operations (Priv_T, Full_List);
Set_Class_Wide_Type
(Base_Type (Full_T), Class_Wide_Type (Priv_T));
Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
end if;
end;
end if;
end Process_Full_View;
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;
else
Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
end if;
while Present (Inc_Elmt) loop
Priv_Dep := Node (Inc_Elmt);
if Ekind (Priv_Dep) = E_Subprogram_Type then
if Etype (Priv_Dep) = Inc_T then
Set_Etype (Priv_Dep, Full_T);
end if;
declare
Formal : Entity_Id;
begin
Formal := First_Formal (Priv_Dep);
while Present (Formal) loop
if Etype (Formal) = Inc_T then
Set_Etype (Formal, Full_T);
end if;
Next_Formal (Formal);
end loop;
end;
elsif Is_Overloadable (Priv_Dep) then
if Is_Tagged_Type (Full_T) 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;
elsif Ekind (Priv_Dep) = E_Subprogram_Body then
return;
else
New_Subt := Create_Itype (E_Void, N);
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;
Next_Elmt (Inc_Elmt);
end loop;
end Process_Incomplete_Dependents;
procedure Process_Range_Expr_In_Decl
(R : Node_Id;
T : Entity_Id;
Check_List : List_Id := Empty_List;
R_Check_Off : Boolean := False)
is
Lo, Hi : Node_Id;
R_Checks : Check_Result;
Type_Decl : Node_Id;
Def_Id : Entity_Id;
begin
Analyze_And_Resolve (R, Base_Type (T));
if Nkind (R) = N_Range then
Lo := Low_Bound (R);
Hi := High_Bound (R);
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))));
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 (Lo, T);
Set_Etype (Hi, T);
end if;
if Nkind (Lo) = N_String_Literal then
Rewrite (Lo,
Make_Attribute_Reference (Sloc (Lo),
Attribute_Name => Name_First,
Prefix => New_Reference_To (T, Sloc (Lo))));
Analyze_And_Resolve (Lo);
end if;
if Nkind (Hi) = N_String_Literal then
Rewrite (Hi,
Make_Attribute_Reference (Sloc (Hi),
Attribute_Name => Name_First,
Prefix => New_Reference_To (T, Sloc (Hi))));
Analyze_And_Resolve (Hi);
end if;
if not Is_Scalar_Type (Etype (Lo)) then
return;
end if;
if Is_Null_Range (Lo, Hi) then
null;
else
if not R_Check_Off then
R_Checks := Range_Check (R, T);
Type_Decl := Parent (R);
while Present (Type_Decl) and then not
(Nkind (Type_Decl) = N_Full_Type_Declaration
or else
Nkind (Type_Decl) = N_Subtype_Declaration
or else
Nkind (Type_Decl) = N_Loop_Statement
or else
Nkind (Type_Decl) = N_Task_Type_Declaration
or else
Nkind (Type_Decl) = N_Single_Task_Declaration
or else
Nkind (Type_Decl) = N_Protected_Type_Declaration
or else
Nkind (Type_Decl) = N_Single_Protected_Declaration)
loop
Type_Decl := Parent (Type_Decl);
end loop;
if Present (Type_Decl) then
if Nkind (Type_Decl) = N_Loop_Statement then
declare
Indic : Node_Id := Parent (R);
begin
while Present (Indic) and then not
(Nkind (Indic) = N_Subtype_Indication)
loop
Indic := Parent (Indic);
end loop;
if Present (Indic) then
Def_Id := Etype (Subtype_Mark (Indic));
Insert_Range_Checks
(R_Checks,
Type_Decl,
Def_Id,
Sloc (Type_Decl),
R,
Do_Before => True);
end if;
end;
else
Def_Id := Defining_Identifier (Type_Decl);
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 (Type_Decl), R);
else
Insert_Range_Checks
(R_Checks, Type_Decl, Def_Id, Sloc (Type_Decl), R);
end if;
end if;
end if;
end if;
end if;
end if;
Get_Index_Bounds (R, Lo, Hi);
if Expander_Active then
Force_Evaluation (Lo);
Force_Evaluation (Hi);
end if;
end Process_Range_Expr_In_Decl;
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;
procedure Analyze_Bound (N : Node_Id);
procedure Analyze_Bound (N : Node_Id) is
begin
Analyze_And_Resolve (N, Any_Real);
if not Is_OK_Static_Expression (N) then
Error_Msg_N
("bound in real type definition is not static", N);
Err := True;
end if;
end Analyze_Bound;
begin
if Present (Spec) then
Lo := Low_Bound (Spec);
Hi := High_Bound (Spec);
Analyze_Bound (Lo);
Analyze_Bound (Hi);
if Err then
Set_Real_Range_Specification (Def, Empty);
end if;
end if;
end Process_Real_Range_Specification;
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;
Full_View_Id : Entity_Id;
Subtype_Mark_Id : Entity_Id;
N_Dynamic_Ityp : Node_Id := Empty;
begin
if Nkind (S) = N_Subtype_Indication then
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;
P := Parent (S);
Subtype_Mark_Id := Entity (Subtype_Mark (S));
if Is_Unchecked_Union (Subtype_Mark_Id)
and then Comes_From_Source (Related_Nod)
then
Error_Msg_N
("cannot create subtype of Unchecked_Union", Related_Nod);
end if;
if Nkind (P) = N_Subtype_Declaration then
Def_Id := Defining_Identifier (P);
elsif Nkind (P) = N_Derived_Type_Definition then
Def_Id := Defining_Identifier (Parent (P));
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
Def_Id :=
Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
end if;
N_Dynamic_Ityp := Related_Nod;
end if;
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));
Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
end if;
case Ekind (Subtype_Mark_Id) is
when Access_Kind =>
Constrain_Access (Def_Id, S, Related_Nod);
when Array_Kind =>
Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
when Decimal_Fixed_Point_Kind =>
Constrain_Decimal (Def_Id, S);
when Enumeration_Kind =>
Constrain_Enumeration (Def_Id, S);
when Ordinary_Fixed_Point_Kind =>
Constrain_Ordinary_Fixed (Def_Id, S);
when Float_Kind =>
Constrain_Float (Def_Id, S);
when Integer_Kind =>
Constrain_Integer (Def_Id, S);
when E_Record_Type |
E_Record_Subtype |
Class_Wide_Kind |
E_Incomplete_Type =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
when Private_Kind =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
Set_Private_Dependents (Def_Id, New_Elmt_List);
if Etype (Def_Id) = Any_Type then
return Def_Id;
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_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);
else
Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
end if;
when Concurrent_Kind =>
Constrain_Concurrent (Def_Id, S,
Related_Nod, Related_Id, Suffix);
when others =>
Error_Msg_N ("invalid subtype mark in subtype indication", S);
end case;
Set_Size_Info (Def_Id, (Subtype_Mark_Id));
Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
return Def_Id;
else
Find_Type (S);
Check_Incomplete (S);
return Entity (S);
end if;
end Process_Subtype;
procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id) is
Def : constant Node_Id := Type_Definition (N);
Range_Checks_Suppressed_Flag : Boolean := False;
Is_Tagged : Boolean;
Tag_Comp : Entity_Id;
begin
Is_Tagged := Tagged_Present (Def)
or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T));
New_Scope (T);
Set_Is_Tagged_Type (T, Is_Tagged);
Set_Is_Limited_Record (T, Limited_Present (Def));
Set_Is_Abstract (T, Is_Abstract (T) or else Abstract_Present (Def));
Set_Ekind (T, E_Record_Type);
Set_Etype (T, T);
Init_Size_Align (T);
Set_Girder_Constraint (T, No_Elist);
Check_Or_Process_Discriminants (N, T);
Set_Is_Constrained (T, not Has_Discriminants (T));
Set_Has_Delayed_Freeze (T, True);
if Is_Tagged then
if Expander_Active then
Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
Enter_Name (Tag_Comp);
Set_Is_Tag (Tag_Comp);
Set_Ekind (Tag_Comp, E_Component);
Set_Etype (Tag_Comp, RTE (RE_Tag));
Set_DT_Entry_Count (Tag_Comp, No_Uint);
Set_Original_Record_Component (Tag_Comp, Tag_Comp);
Init_Component_Location (Tag_Comp);
end if;
Make_Class_Wide_Type (T);
Set_Primitive_Operations (T, New_Elmt_List);
end if;
if Has_Discriminants (T) and then not Suppress_Range_Checks (T) then
Set_Suppress_Range_Checks (T, True);
Range_Checks_Suppressed_Flag := True;
end if;
Record_Type_Definition (Def, T);
if Range_Checks_Suppressed_Flag then
Set_Suppress_Range_Checks (T, False);
Range_Checks_Suppressed_Flag := False;
end if;
End_Scope;
end Record_Type_Declaration;
procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id) is
Component : Entity_Id;
Ctrl_Components : Boolean := False;
Final_Storage_Only : Boolean := not Is_Controlled (T);
begin
if No (Def)
or else No (Component_List (Def))
or else Null_Present (Component_List (Def))
then
null;
else
Analyze_Declarations (Component_Items (Component_List (Def)));
if Present (Variant_Part (Component_List (Def))) then
Analyze (Variant_Part (Component_List (Def)));
end if;
end if;
Component := First_Entity (Current_Scope);
while Present (Component) loop
if Ekind (Component) = E_Void then
Set_Ekind (Component, E_Component);
Init_Component_Location (Component);
end if;
if Has_Task (Etype (Component)) then
Set_Has_Task (T);
end if;
if Ekind (Component) /= E_Component then
null;
elsif Has_Controlled_Component (Etype (Component))
or else (Chars (Component) /= Name_uParent
and then Is_Controlled (Etype (Component)))
then
Set_Has_Controlled_Component (T, True);
Final_Storage_Only := Final_Storage_Only
and then Finalize_Storage_Only (Etype (Component));
Ctrl_Components := True;
end if;
Next_Entity (Component);
end loop;
if Ctrl_Components then
Set_Finalize_Storage_Only (T, Final_Storage_Only);
end if;
if Present (Def) then
Process_End_Label (Def, 'e', T);
end if;
end Record_Type_Definition;
procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is
function Process (N : Node_Id) return Traverse_Result;
function Process (N : Node_Id) return Traverse_Result is
Comp : Entity_Id;
begin
if Nkind (N) = N_Discriminant_Specification then
Comp := First_Discriminant (Typ);
while Present (Comp) loop
if Chars (Comp) = Chars (Defining_Identifier (N)) then
Set_Defining_Identifier (N, Comp);
exit;
end if;
Next_Discriminant (Comp);
end loop;
elsif Nkind (N) = N_Component_Declaration then
Comp := First_Component (Typ);
while Present (Comp) loop
if Chars (Comp) = Chars (Defining_Identifier (N)) then
Set_Defining_Identifier (N, Comp);
exit;
end if;
Next_Component (Comp);
end loop;
end if;
return OK;
end Process;
procedure Replace is new Traverse_Proc (Process);
begin
Replace (Decl);
end Replace_Components;
procedure Set_Completion_Referenced (E : Entity_Id) is
begin
if In_Extended_Main_Source_Unit (E) then
Set_Referenced (E);
end if;
end Set_Completion_Referenced;
procedure Set_Fixed_Range
(E : Entity_Id;
Loc : Source_Ptr;
Lo : Ureal;
Hi : Ureal)
is
S : constant Node_Id :=
Make_Range (Loc,
Low_Bound => Make_Real_Literal (Loc, Lo),
High_Bound => Make_Real_Literal (Loc, Hi));
begin
Set_Scalar_Range (E, S);
Set_Parent (S, E);
end Set_Fixed_Range;
procedure Set_Girder_Constraint_From_Discriminant_Constraint
(E : Entity_Id)
is
begin
Set_Girder_Constraint (E, No_Elist);
if Is_Constrained (E) and then Has_Discriminants (E) then
Set_Girder_Constraint (E,
Expand_To_Girder_Constraint (E, Discriminant_Constraint (E)));
end if;
end Set_Girder_Constraint_From_Discriminant_Constraint;
procedure Set_Scalar_Range_For_Subtype
(Def_Id : Entity_Id;
R : Node_Id;
Subt : Entity_Id)
is
Kind : constant Entity_Kind := Ekind (Def_Id);
begin
Set_Scalar_Range (Def_Id, R);
if No (Parent (R)) then
Set_Parent (R, Def_Id);
end if;
Set_Ekind (Def_Id, E_Void);
Process_Range_Expr_In_Decl (R, Subt);
Set_Ekind (Def_Id, Kind);
end Set_Scalar_Range_For_Subtype;
procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is
Implicit_Base : Entity_Id;
Base_Typ : Entity_Id;
Lo_Val : Uint;
Hi_Val : Uint;
Errs : Boolean := False;
Lo : Node_Id;
Hi : Node_Id;
function Can_Derive_From (E : Entity_Id) return Boolean;
procedure Check_Bound (Expr : Node_Id);
function Can_Derive_From (E : Entity_Id) return Boolean is
Lo : constant Uint := Expr_Value (Type_Low_Bound (E));
Hi : constant Uint := Expr_Value (Type_High_Bound (E));
begin
return Lo <= Lo_Val and then Lo_Val <= Hi
and then
Lo <= Hi_Val and then Hi_Val <= Hi;
end Can_Derive_From;
procedure Check_Bound (Expr : Node_Id) is
begin
if not Is_Integer_Type (Etype (Expr)) then
Error_Msg_N
("integer type definition bounds must be of integer type", Expr);
Errs := True;
elsif not Is_OK_Static_Expression (Expr) then
Error_Msg_N
("non-static expression used for integer type bound", Expr);
Errs := True;
else
if Is_Entity_Name (Expr) then
Fold_Uint (Expr, Expr_Value (Expr));
end if;
Set_Etype (Expr, Universal_Integer);
end if;
end Check_Bound;
begin
Implicit_Base :=
Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B');
Lo := Low_Bound (Def);
Hi := High_Bound (Def);
if Hi = Error or else Lo = Error then
Base_Typ := Any_Integer;
Set_Error_Posted (T, True);
else
Analyze_And_Resolve (Lo, Any_Integer);
Analyze_And_Resolve (Hi, Any_Integer);
Check_Bound (Lo);
Check_Bound (Hi);
if Errs then
Hi := Type_High_Bound (Standard_Long_Long_Integer);
Lo := Type_Low_Bound (Standard_Long_Long_Integer);
end if;
Lo_Val := Expr_Value (Lo);
Hi_Val := Expr_Value (Hi);
if Can_Derive_From (Standard_Short_Short_Integer) then
Base_Typ := Base_Type (Standard_Short_Short_Integer);
elsif Can_Derive_From (Standard_Short_Integer) then
Base_Typ := Base_Type (Standard_Short_Integer);
elsif Can_Derive_From (Standard_Integer) then
Base_Typ := Base_Type (Standard_Integer);
elsif Can_Derive_From (Standard_Long_Integer) then
Base_Typ := Base_Type (Standard_Long_Integer);
elsif Can_Derive_From (Standard_Long_Long_Integer) then
Base_Typ := Base_Type (Standard_Long_Long_Integer);
else
Base_Typ := Base_Type (Standard_Long_Long_Integer);
Error_Msg_N ("integer type definition bounds out of range", Def);
Hi := Type_High_Bound (Standard_Long_Long_Integer);
Lo := Type_Low_Bound (Standard_Long_Long_Integer);
end if;
end if;
Set_Etype (Implicit_Base, Base_Typ);
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_Ekind (T, E_Signed_Integer_Subtype);
Set_Etype (T, Implicit_Base);
Set_Size_Info (T, (Implicit_Base));
Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
Set_Scalar_Range (T, Def);
Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
Set_Is_Constrained (T);
end Signed_Integer_Type_Declaration;
end Sem_Ch3;