-- --
-- B o d y --
-- --
--- $Revision: 1.2 $
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- process an implicit derived full type for a type derived from a private
-- type (in that case the subprograms must only be derived for the private
-- view of the type).
- -- ??? These flags need a bit of re-examination and re-documentaion:
+ -- ??? These flags need a bit of re-examination and re-documentation:
-- ??? are they both necessary (both seem related to the recursion)?
procedure Build_Derived_Access_Type
-- procedures for the type where Discrim is a discriminant. Discriminals
-- are not used during semantic analysis, and are not fully defined
-- entities until expansion. Thus they are not given a scope until
- -- intialization procedures are built.
+ -- initialization procedures are built.
function Build_Discriminant_Constraints
(T : Entity_Id;
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
- Der_T : Entity_Id;
- Loc : Source_Ptr)
+ Der_T : Entity_Id)
return Node_Id;
-- The bounds of a derived scalar type are conversions of the bounds of
-- the parent type. Optimize the representation if the bounds are literals.
-- Empty for Def_Id indicates that an implicit type must be created, but
-- creation is delayed (and must be done by this procedure) because other
-- subsidiary implicit types must be created first (which is why Def_Id
- -- is an in/out parameter). Related_Nod gives the place where this type has
- -- to be inserted in the tree. The Related_Id and Suffix parameters are
- -- used to build the associated Implicit type name.
+ -- is an in/out parameter). The second parameter is a subtype indication
+ -- node for the constrained array to be created (e.g. something of the
+ -- form string (1 .. 10)). Related_Nod gives the place where this type
+ -- has to be inserted in the tree. The Related_Id and Suffix parameters
+ -- are used to build the associated Implicit type name.
procedure Constrain_Concurrent
(Def_Id : in out Entity_Id;
-- When constraining a protected type or task type with discriminants,
-- constrain the corresponding record with the same discriminant values.
- procedure Constrain_Decimal
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id);
+ procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id);
-- Constrain a decimal fixed point type with a digits constraint and/or a
-- range constraint, and build E_Decimal_Fixed_Point_Subtype entity.
-- Constrain_Concurrent. See Build_Discrimated_Subtype for an explanation
-- of For_Access.
- procedure Constrain_Enumeration
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id);
+ procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id);
-- Constrain an enumeration type with a range constraint. This is
-- identical to Constrain_Integer, but for the Ekind of the
-- resulting subtype.
- procedure Constrain_Float
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id);
+ procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id);
-- Constrain a floating point type with either a digits constraint
-- and/or a range constraint, building a E_Floating_Point_Subtype.
-- unconstrained array. The Related_Id and Suffix parameters are used to
-- build the associated Implicit type name.
- procedure Constrain_Integer
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id);
+ procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id);
-- Build subtype of a signed or modular integer type.
- procedure Constrain_Ordinary_Fixed
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id);
+ procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id);
-- Constrain an ordinary fixed point type with a range constraint, and
-- build an E_Ordinary_Fixed_Point_Subtype entity.
-- type. It is provided so that its Has_Task flag can be set if any of
-- the component have Has_Task set.
+ procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id);
+ -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
+ -- build a copy of the declaration tree of the parent, and we create
+ -- independently the list of components for the derived type. Semantic
+ -- information uses the component entities, but record representation
+ -- clauses are validated on the declaration tree. This procedure replaces
+ -- discriminants and components in the declaration with those that have
+ -- been created by Inherit_Components.
+
procedure Set_Fixed_Range
(E : Entity_Id;
Loc : Source_Ptr;
-- for the constructed range. See body for further details.
procedure Set_Scalar_Range_For_Subtype
- (Def_Id : Entity_Id;
- R : Node_Id;
- Subt : Entity_Id;
- Related_Nod : Node_Id);
+ (Def_Id : Entity_Id;
+ R : Node_Id;
+ Subt : Entity_Id);
-- This routine is used to set the scalar range field for a subtype
-- given Def_Id, the entity for the subtype, and R, the range expression
-- for the scalar range. Subt provides the parent subtype to be used
return Entity_Id
is
Anon_Type : constant Entity_Id :=
- Create_Itype (E_Anonymous_Access_Type, Related_Nod,
- Scope_Id => Scope (Current_Scope));
+ Create_Itype (E_Anonymous_Access_Type, Related_Nod,
+ Scope_Id => Scope (Current_Scope));
Desig_Type : Entity_Id;
begin
if Present (Formals) then
New_Scope (Desig_Type);
- Process_Formals (Desig_Type, Formals, Parent (T_Def));
+ Process_Formals (Formals, Parent (T_Def));
-- A bit of a kludge here, End_Scope requires that the parent
-- pointer be set to something reasonable, but Itypes don't
Constant_Redeclaration (Id, N, T);
Generate_Reference (Prev_Entity, Id, 'c');
-
- -- If in main unit, set as referenced, so we do not complain about
- -- the full declaration being an unreferenced entity.
-
- if In_Extended_Main_Source_Unit (Id) then
- Set_Referenced (Id);
- end if;
+ Set_Completion_Referenced (Id);
if Error_Posted (N) then
-- Type mismatch or illegal redeclaration, Do not analyze
-- If deferred constant, make sure context is appropriate. We detect
-- a deferred constant as a constant declaration with no expression.
+ -- A deferred constant can appear in a package body if its completion
+ -- is by means of an interface pragma.
if Constant_Present (N)
and then No (E)
then
- if not Is_Package (Current_Scope)
- or else In_Private_Part (Current_Scope)
- then
+ if not Is_Package (Current_Scope) then
Error_Msg_N
("invalid context for deferred constant declaration", N);
Set_Constant_Present (N, False);
if not Is_Constrained (T) then
null;
+ elsif Nkind (E) = N_Raise_Constraint_Error then
+
+ -- Aggregate is statically illegal. Place back in declaration
+
+ Set_Expression (N, E);
+ Set_No_Initialization (N, False);
+
elsif T = Etype (E) then
null;
Check_Restriction (No_Task_Hierarchy, N);
Check_Potentially_Blocking_Operation (N);
end if;
+
+ -- A rather specialized test. If we see two tasks being declared
+ -- of the same type in the same object declaration, and the task
+ -- has an entry with an address clause, we know that program error
+ -- will be raised at run-time since we can't have two tasks with
+ -- entries at the same address.
+
+ 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;
-- Some simple constant-propagation: if the expression is a constant
-- of the others choice will occur as part of the processing of the parent
procedure Analyze_Others_Choice (N : Node_Id) is
+ pragma Warnings (Off, N);
+
begin
null;
end Analyze_Others_Choice;
end if;
when Concurrent_Kind =>
-
Set_Ekind (Id, Subtype_Kind (Ekind (T)));
Set_Corresponding_Record_Type (Id,
Corresponding_Record_Type (T));
-- and the second parameter provides the reference location.
Generate_Reference (T, T, 'c');
-
- -- If in main unit, set as referenced, so we do not complain about
- -- the full declaration being an unreferenced entity.
-
- if In_Extended_Main_Source_Unit (Def_Id) then
- Set_Referenced (Def_Id);
- end if;
+ Set_Completion_Referenced (Def_Id);
-- For completion of incomplete type, process incomplete dependents
-- and always mark the full type as referenced (it is the incomplete
elsif Ekind (Prev) = E_Incomplete_Type then
Process_Incomplete_Dependents (N, T, Prev);
Generate_Reference (Prev, Def_Id, 'c');
-
- -- If in main unit, set as referenced, so we do not complain about
- -- the full declaration being an unreferenced entity.
-
- if In_Extended_Main_Source_Unit (Def_Id) then
- Set_Referenced (Def_Id);
- end if;
+ Set_Completion_Referenced (Def_Id);
-- If not private type or incomplete type completion, this is a real
-- definition of a new entity, so record it.
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;
+
-- Call the instantiated Analyze_Choices which does the rest of the work
Analyze_Choices
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_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));
+ 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));
-- Unconstrained array case
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));
+ 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 (T, Element_Type);
+ Set_Component_Type (Base_Type (T), Element_Type);
if Aliased_Present (Def) then
Set_Has_Aliased_Components (Etype (T));
Priv := Private_Component (Element_Type);
if Present (Priv) then
- -- Check for circular definitions.
+
+ -- Check for circular definitions
if Priv = Any_Type then
- Set_Component_Type (T, Any_Type);
Set_Component_Type (Etype (T), Any_Type);
-- There is a gap in the visiblity of operations on the composite
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_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);
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;
+ Nkind (Subtype_Indication (Type_Definition (N)))
+ = N_Subtype_Indication;
begin
Set_Girder_Constraint (Derived_Type, No_Elist);
New_Scope (Derived_Type);
Check_Or_Process_Discriminants (N, Derived_Type);
End_Scope;
+
+ elsif Constraint_Present then
+
+ -- Build constrained subtype and derive from it
+
+ 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;
-- All attributes are inherited from parent. In particular,
-- Discriminants may be renamed, and must be treated separately.
Set_Has_Discriminants
- (Derived_Type, Has_Discriminants (Parent_Type));
+ (Derived_Type, Has_Discriminants (Parent_Type));
Set_Corresponding_Record_Type
- (Derived_Type, Corresponding_Record_Type
- (Parent_Type));
+ (Derived_Type, Corresponding_Record_Type (Parent_Type));
if Constraint_Present then
New_Disc := First_Discriminant (Derived_Type);
Disc_Spec := First (Discriminant_Specifications (N));
D_Constraint :=
- First (Constraints (
- Constraint (Subtype_Indication (Type_Definition (N)))));
+ 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
+ N_Access_Definition
then
Analyze (Discriminant_Type (Disc_Spec));
+
if not Subtypes_Statically_Compatible (
Etype (Discriminant_Type (Disc_Spec)),
Etype (Old_Disc))
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));
begin
if Nkind (R) = N_Range then
Hi := Build_Scalar_Bound
- (High_Bound (R), Parent_Type, Implicit_Base, Loc);
+ (High_Bound (R), Parent_Type, Implicit_Base);
Lo := Build_Scalar_Bound
- (Low_Bound (R), Parent_Type, Implicit_Base, Loc);
+ (Low_Bound (R), Parent_Type, Implicit_Base);
else
-- Constraint is a Range attribute. Replace with the
Hi :=
Build_Scalar_Bound
(Type_High_Bound (Parent_Type),
- Parent_Type, Implicit_Base, Loc);
+ Parent_Type, Implicit_Base);
Lo :=
Build_Scalar_Bound
(Type_Low_Bound (Parent_Type),
- Parent_Type, Implicit_Base, Loc);
+ Parent_Type, Implicit_Base);
end if;
Rang_Expr :=
--------------------------------
procedure Build_Derived_Private_Type
- (N : Node_Id;
- Parent_Type : Entity_Id;
- Derived_Type : Entity_Id;
+ (N : Node_Id;
+ Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
Is_Completion : Boolean;
Derive_Subps : Boolean := True)
is
-- Copy derived type declaration, replace parent with its full view,
-- and analyze new declaration.
+ --------------------
+ -- Copy_And_Build --
+ --------------------
+
procedure Copy_And_Build is
Full_N : Node_Id;
return;
end if;
- -- Inherit the discriminants of the full view, but
- -- keep the proper parent type.
+ -- If full view of parent is a record type, Build full view as
+ -- a derivation from the parent's full view. Partial view remains
+ -- private.
- -- ??? this looks wrong, we are replacing (and thus,
- -- erasing) the partial view!
+ 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;
-- In any case, the primitive operations are inherited from
-- the parent type, not from the internal full view.
- Build_Derived_Record_Type
- (N, Full_View (Parent_Type), Derived_Type,
- Derive_Subps => False);
Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type));
if Derive_Subps then
end if;
else
-
- -- Untagged type, No discriminants on either view.
+ -- Untagged type, No discriminants on either view
if Nkind (Subtype_Indication (Type_Definition (N)))
= N_Subtype_Indication
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));
+ 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));
- -- Direct controlled types do not inherit the Finalize_Storage_Only
- -- flag.
+ -- Direct controlled types do not inherit Finalize_Storage_Only flag
if not Is_Controlled (Parent_Type) then
- Set_Finalize_Storage_Only (Derived_Type,
- Finalize_Storage_Only (Parent_Type));
+ Set_Finalize_Storage_Only
+ (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
end if;
-- Construct the implicit full view by deriving from full
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;
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
-- This is the unusual case where a type completed by a private
-- derivation occurs within a package nested in a child unit,
-- type T (...) is new R (...) [with ...];
-- The representation clauses of T can specify a completely different
- -- record layout from R's. Hence a same component can be placed in two very
- -- different positions in objects of type T and R. If R and T are tagged
- -- types, representation clauses for T can only specify the layout of non
- -- inherited components, thus components that are common in R and T have
- -- the same position in objects of type R or T.
+ -- record layout from R's. Hence the same component can be placed in
+ -- two very different positions in objects of type T and R. If R and T
+ -- are tagged types, representation clauses for T can only specify the
+ -- layout of non inherited components, thus components that are common
+ -- in R and T have the same position in objects of type R and T.
-- This has two implications. The first is that the entire tree for R's
-- declaration needs to be copied for T in the untagged case, so that
-- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if
-- there is one;
- -- o Otherwise, each discriminant of the parent type (implicitely
+ -- o Otherwise, each discriminant of the parent type (implicitly
-- declared in the same order with the same specifications). In this
-- case, the discriminants are said to be "inherited", or if unknown in
-- the parent are also unknown in the derived type.
-- Then the above transformation turns this into
-- type Der_Base is new Base with null record;
- -- -- procedure P (X : Base) is implicitely inherited here
+ -- -- procedure P (X : Base) is implicitly inherited here
-- -- as procedure P (X : Der_Base).
-- subtype Der is Der_Base (2);
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);
+ 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;
+ Save_Etype : Entity_Id;
+ Save_Discr_Constr : Elist_Id;
+ Save_Next_Entity : Entity_Id;
begin
if Ekind (Parent_Type) = E_Record_Type_With_Private
Set_Has_Primitive_Operations
(Derived_Type, Has_Primitive_Operations (Parent_Base));
- -- Direct controlled types do not inherit the Finalize_Storage_Only
- -- flag.
+ -- Direct controlled types do not inherit Finalize_Storage_Only flag
if not Is_Controlled (Parent_Type) then
- Set_Finalize_Storage_Only (Derived_Type,
- Finalize_Storage_Only (Parent_Type));
+ Set_Finalize_Storage_Only
+ (Derived_Type, Finalize_Storage_Only (Parent_Type));
end if;
-- Set fields for private derived types.
(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;
-- Insert the new derived type declaration
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
is
Has_Discrs : constant Boolean := Has_Discriminants (T);
Constrained : constant Boolean
- := (Has_Discrs and then not Is_Empty_Elmt_List (Elist))
+ := (Has_Discrs
+ and then not Is_Empty_Elmt_List (Elist)
+ and then not Is_Class_Wide_Type (T))
or else Is_Constrained (T);
begin
function Build_Scalar_Bound
(Bound : Node_Id;
Par_T : Entity_Id;
- Der_T : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Der_T : Entity_Id)
+ return Node_Id
is
New_Bound : Entity_Id;
if not Comes_From_Source (E) then
pragma Assert
- (Errors_Detected > 0
+ (Serious_Errors_Detected > 0
or else Subunits_Missing
or else not Expander_Active);
return;
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
Obj_Def : constant Node_Id := Object_Definition (N);
New_T : Entity_Id;
+ procedure Check_Recursive_Declaration (Typ : Entity_Id);
+ -- If deferred constant is an access type initialized with an
+ -- allocator, check whether there is an illegal recursion in the
+ -- definition, through a default value of some record subcomponent.
+ -- This is normally detected when generating init_procs, but requires
+ -- this additional mechanism when expansion is disabled.
+
+ 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;
+
+ -- Start of processing for Constant_Redeclaration
+
begin
if Nkind (Parent (Prev)) = N_Object_Declaration then
if Nkind (Object_Definition
if Ekind (Prev) /= E_Constant
or else Present (Expression (Parent (Prev)))
+ or else Present (Full_View (Prev))
then
Enter_Name (Id);
Error_Msg_N ("ALIASED required (see declaration#)", N);
end if;
- -- Check that placement is in private part
+ -- Check that placement is in private part and that the incomplete
+ -- declaration appeared in the visible part.
if Ekind (Current_Scope) = E_Package
and then not In_Private_Part (Current_Scope)
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;
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
+ -- Enforce rule that the constraint is illegal if there is
+ -- an unconstrained view of the designated type. This means
+ -- that the partial view (either a private type declaration or
+ -- a derivation from a private type) has no discriminants.
+ -- (Defect Report 8652/0008, Technical Corrigendum 1, checked
+ -- by ACATS B371001).
+
+ 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);
Set_First_Index (Def_Id, First (Constraints (C)));
end if;
- Set_Component_Type (Def_Id, Component_Type (T));
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));
function Is_Discriminant (Expr : Node_Id) return Boolean;
-- Returns True if Expr is a discriminant.
- function Get_Value (Discrim : Entity_Id) return Node_Id;
+ function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
-- Find the value of discriminant Discrim in Constraint.
-----------------------------------
Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
if Is_Discriminant (Lo_Expr) then
- Lo_Expr := Get_Value (Lo_Expr);
+ Lo_Expr := Get_Discr_Value (Lo_Expr);
end if;
if Is_Discriminant (Hi_Expr) then
- Hi_Expr := Get_Value (Hi_Expr);
+ Hi_Expr := Get_Discr_Value (Hi_Expr);
end if;
Range_Node :=
Expr := Node (Old_Constraint);
if Is_Discriminant (Expr) then
- Expr := Get_Value (Expr);
+ Expr := Get_Discr_Value (Expr);
end if;
Append (New_Copy_Tree (Expr), To => Constr_List);
return Def_Id;
end Build_Subtype;
- ---------------
- -- Get_Value --
- ---------------
+ ---------------------
+ -- Get_Discr_Value --
+ ---------------------
- function Get_Value (Discrim : Entity_Id) return Node_Id is
+ 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 we are constraining the subtype of a derived tagged type,
- -- recover the discriminant of the parent, which appears in
- -- the constraint of an inherited component.
+ -- The discriminant may be declared for the type, in which case we
+ -- find it by iterating over the list of discriminants. If the
+ -- discriminant is inherited from a parent type, it appears as the
+ -- corresponding discriminant of the current type. This will be the
+ -- case when constraining an inherited component whose constraint is
+ -- given by a discriminant of the parent.
+ while Present (D) loop
if D = Entity (Discrim)
or else Corresponding_Discriminant (D) = Entity (Discrim)
then
Next_Elmt (E);
end loop;
+ -- The corresponding_Discriminant mechanism is incomplete, because
+ -- the correspondence between new and old discriminants is not one
+ -- to one: one new discriminant can constrain several old ones.
+ -- In that case, scan sequentially the girder_constraint, the list
+ -- of discriminants of the parents, and the constraints.
+
+ 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;
+
-- Something is wrong if we did not find the value
raise Program_Error;
- end Get_Value;
+ end Get_Discr_Value;
---------------------
-- Is_Discriminant --
-- Constrain_Decimal --
-----------------------
- procedure Constrain_Decimal
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id)
- is
+ 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);
end if;
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T, Related_Nod);
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T);
Set_Discrete_RM_Size (Def_Id);
-- Unconditionally delay the freeze, since we cannot set size
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;
Fixup_Bad_Constraint;
return;
- elsif Is_Constrained (Entity (Subtype_Mark (S))) then
+ 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;
-- Constrain_Enumeration --
---------------------------
- procedure Constrain_Enumeration
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id)
- is
+ 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);
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, Related_Nod);
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
Set_Discrete_RM_Size (Def_Id);
-- Constrain_Float --
----------------------
- procedure Constrain_Float
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id)
- is
+ 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;
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));
+ Rais :=
+ Make_Raise_Constraint_Error (Sloc (D),
+ Reason => CE_Range_Check_Failed);
Insert_Action (Declaration_Node (Def_Id), Rais);
end if;
-- Range constraint present
if Nkind (C) = N_Range_Constraint then
- Set_Scalar_Range_For_Subtype
- (Def_Id, Range_Expression (C), T, Related_Nod);
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
-- No range constraint present
Suffix_Index : Nat)
is
Def_Id : Entity_Id;
- R : Node_Id;
+ R : Node_Id := Empty;
Checks_Off : Boolean := False;
T : constant Entity_Id := Etype (Index);
Checks_Off := True;
end if;
- Process_Range_Expr_In_Decl
- (R, T, Related_Nod, Empty_List, Checks_Off);
+ Process_Range_Expr_In_Decl (R, T, Empty_List, Checks_Off);
if not Error_Posted (S)
and then
Set_RM_Size (Def_Id, RM_Size (T));
Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- -- ??? ??? is R always initialized, not at all obvious why?
-
Set_Scalar_Range (Def_Id, R);
Set_Etype (S, Def_Id);
-- Constrain_Integer --
-----------------------
- procedure Constrain_Integer
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id)
- is
+ 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, Related_Nod);
+ 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);
-- Constrain_Ordinary_Fixed --
------------------------------
- procedure Constrain_Ordinary_Fixed
- (Def_Id : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id)
- is
+ 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;
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));
+ Rais :=
+ Make_Raise_Constraint_Error (Sloc (D),
+ Reason => CE_Range_Check_Failed);
Insert_Action (Declaration_Node (Def_Id), Rais);
end if;
-- Range constraint present
if Nkind (C) = N_Range_Constraint then
- Set_Scalar_Range_For_Subtype
- (Def_Id, Range_Expression (C), T, Related_Nod);
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
-- No range constraint present
begin
Lo := Build_Scalar_Bound
(Type_Low_Bound (Derived_Type),
- Parent_Type, Implicit_Base, Loc);
+ Parent_Type, Implicit_Base);
Hi := Build_Scalar_Bound
(Type_High_Bound (Derived_Type),
- Parent_Type, Implicit_Base, Loc);
+ Parent_Type, Implicit_Base);
Rng :=
Make_Range (Loc,
if Is_Tagged_Type (T) then
Set_Primitive_Operations (T, New_Elmt_List);
end if;
+
return;
elsif Is_Unchecked_Union (Parent_Type) then
then
Set_Discard_Names (T);
end if;
+
+ -- Process end label if there is one
+
+ if Present (Def) then
+ Process_End_Label (Def, 'e', T);
+ end if;
end Enumeration_Type_Declaration;
--------------------------
end if;
Copy_And_Swap (Prev, Id);
- Set_Full_View (Id, Prev);
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
+
+ -- If no error, propagate freeze_node from private to full view.
+ -- It may have been generated for an early operational item.
+
+ 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;
-- Otherwise we have a subtype mark without a constraint
+ elsif Error_Posted (S) then
+ Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S)));
+ return Any_Type;
+
else
Find_Type (S);
Typ := Entity (S);
Set_Corresponding_Discriminant (New_C, Old_C);
Build_Discriminal (New_C);
- -- If we are explicitely inheriting a girder discriminant it will be
+ -- If we are explicitly inheriting a girder discriminant it will be
-- completely hidden.
elsif Girder_Discrim then
Set_Has_Delayed_Freeze (CW_Type);
-- Customize the class-wide type: It has no prim. op., it cannot be
- -- abstract and its Etype points back to the root type
+ -- abstract and its Etype points back to the specific root 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_Etype (CW_Type, T);
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;
+
-- If this is the class_wide type of a constrained subtype, it does
-- not have discriminants.
end if;
R := I;
- Process_Range_Expr_In_Decl (R, T, Related_Nod);
+ Process_Range_Expr_In_Decl (R, T);
elsif Nkind (I) = N_Subtype_Indication then
R := Range_Expression (Constraint (I));
Resolve (R, T);
- Process_Range_Expr_In_Decl (R,
- Entity (Subtype_Mark (I)), Related_Nod);
+ Process_Range_Expr_In_Decl (R, Entity (Subtype_Mark (I)));
elsif Nkind (I) = N_Attribute_Reference then
-- The parser guarantees that the attribute is a RANGE attribute
- -- Is order critical here (setting T before Resolve). If so,
- -- document why, if not use Analyze_And_Resolve and get T after???
-
- Analyze (I);
+ Analyze_And_Resolve (I);
T := Etype (I);
- Resolve (I, T);
R := I;
-- If none of the above, must be a subtype. We convert this to a
procedure Process_Range_Expr_In_Decl
(R : Node_Id;
T : Entity_Id;
- Related_Nod : Node_Id;
Check_List : List_Id := Empty_List;
R_Check_Off : Boolean := False)
is
Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
when Decimal_Fixed_Point_Kind =>
- Constrain_Decimal (Def_Id, S, N_Dynamic_Ityp);
+ Constrain_Decimal (Def_Id, S);
when Enumeration_Kind =>
- Constrain_Enumeration (Def_Id, S, N_Dynamic_Ityp);
+ Constrain_Enumeration (Def_Id, S);
when Ordinary_Fixed_Point_Kind =>
- Constrain_Ordinary_Fixed (Def_Id, S, N_Dynamic_Ityp);
+ Constrain_Ordinary_Fixed (Def_Id, S);
when Float_Kind =>
- Constrain_Float (Def_Id, S, N_Dynamic_Ityp);
+ Constrain_Float (Def_Id, S);
when Integer_Kind =>
- Constrain_Integer (Def_Id, S, N_Dynamic_Ityp);
+ Constrain_Integer (Def_Id, S);
when E_Record_Type |
E_Record_Subtype |
-- private tagged types where the full view omits the word tagged.
Is_Tagged := Tagged_Present (Def)
- or else (Errors_Detected > 0 and then Is_Tagged_Type (T));
+ or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T));
-- Records constitute a scope for the component declarations within.
-- The scope is created prior to the processing of these declarations.
end if;
if Present (Def) then
- Process_End_Label (Def, 'e');
+ Process_End_Label (Def, 'e', T);
end if;
end Record_Type_Definition;
+ ------------------------
+ -- Replace_Components --
+ ------------------------
+
+ procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is
+ function Process (N : Node_Id) return Traverse_Result;
+
+ -------------
+ -- Process --
+ -------------
+
+ 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);
+
+ -- Start of processing for Replace_Components
+
+ begin
+ Replace (Decl);
+ end Replace_Components;
+
+ -------------------------------
+ -- Set_Completion_Referenced --
+ -------------------------------
+
+ procedure Set_Completion_Referenced (E : Entity_Id) is
+ begin
+ -- If in main unit, mark entity that is a completion as referenced,
+ -- warnings go on the partial view when needed.
+
+ if In_Extended_Main_Source_Unit (E) then
+ Set_Referenced (E);
+ end if;
+ end Set_Completion_Referenced;
+
---------------------
-- Set_Fixed_Range --
---------------------
----------------------------------
procedure Set_Scalar_Range_For_Subtype
- (Def_Id : Entity_Id;
- R : Node_Id;
- Subt : Entity_Id;
- Related_Nod : Node_Id)
+ (Def_Id : Entity_Id;
+ R : Node_Id;
+ Subt : Entity_Id)
is
Kind : constant Entity_Kind := Ekind (Def_Id);
begin
-- catch possible premature use in the bounds themselves.
Set_Ekind (Def_Id, E_Void);
- Process_Range_Expr_In_Decl (R, Subt, Related_Nod);
+ Process_Range_Expr_In_Decl (R, Subt);
Set_Ekind (Def_Id, Kind);
end Set_Scalar_Range_For_Subtype;
OSDN Git Service
