-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
+with Ghost; use Ghost;
with Itypes; use Itypes;
with Layout; use Layout;
with Lib; use Lib;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
-- record type.
procedure Analyze_Object_Contract (Obj_Id : Entity_Id);
- -- Analyze all delayed aspects chained on the contract of object Obj_Id as
- -- if they appeared at the end of the declarative region. The aspects to be
+ -- Analyze all delayed pragmas chained on the contract of object Obj_Id as
+ -- if they appeared at the end of the declarative region. The pragmas to be
-- considered are:
-- Async_Readers
-- Async_Writers
function Find_Type_Of_Object
(Obj_Def : Node_Id;
Related_Nod : Node_Id) return Entity_Id;
- -- Get type entity for object referenced by Obj_Def, attaching the
- -- implicit types generated to Related_Nod
+ -- Get type entity for object referenced by Obj_Def, attaching the implicit
+ -- types generated to Related_Nod.
procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id);
-- Create a new float and apply the constraint to obtain subtype of it
-- Propagate static and dynamic predicate flags from a parent to the
-- subtype in a subtype declaration with and without constraints.
+ function Is_EVF_Procedure (Subp : Entity_Id) return Boolean;
+ -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram.
+ -- Determine whether subprogram Subp is a procedure subject to pragma
+ -- Extensions_Visible with value False and has at least one controlling
+ -- parameter of mode OUT.
+
function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind;
Constraint_Kind : Node_Kind) return Boolean;
-- present. If errors are found, error messages are posted, and the
-- Real_Range_Specification of Def is reset to Empty.
+ procedure Propagate_Default_Init_Cond_Attributes
+ (From_Typ : Entity_Id;
+ To_Typ : Entity_Id;
+ Parent_To_Derivation : Boolean := False;
+ Private_To_Full_View : Boolean := False);
+ -- Subsidiary to routines Build_Derived_Type and Process_Full_View. Inherit
+ -- all attributes related to pragma Default_Initial_Condition from From_Typ
+ -- to To_Typ. Flag Parent_To_Derivation should be set when the context is
+ -- the creation of a derived type. Flag Private_To_Full_View should be set
+ -- when processing both views of a private type.
+
procedure Record_Type_Declaration
(T : Entity_Id;
N : Node_Id;
Enclosing_Prot_Type : Entity_Id := Empty;
begin
- Check_SPARK_Restriction ("access type is not allowed", N);
+ Check_SPARK_05_Restriction ("access type is not allowed", N);
if Is_Entry (Current_Scope)
and then Is_Task_Type (Etype (Scope (Current_Scope)))
-- create a reference to it after the enclosing protected definition
-- because the itype will be used in the subsequent bodies.
- if Ekind (Current_Scope) = E_Protected_Type then
+ -- If the anonymous access itself is protected, a full type
+ -- declaratiton will be created for it, so that the equivalent
+ -- record type can be constructed. For further details, see
+ -- Replace_Anonymous_Access_To_Protected-Subprogram.
+
+ if Ekind (Current_Scope) = E_Protected_Type
+ and then not Protected_Present (Access_To_Subprogram_Definition (N))
+ then
Build_Itype_Reference (Anon_Type, Parent (Current_Scope));
end if;
-- Start of processing for Access_Subprogram_Declaration
begin
- Check_SPARK_Restriction ("access type is not allowed", T_Def);
+ Check_SPARK_05_Restriction ("access type is not allowed", T_Def);
-- Associate the Itype node with the inner full-type declaration or
-- subprogram spec or entry body. This is required to handle nested
if Is_Access_Type (Typ)
and then Null_Exclusion_In_Return_Present (T_Def)
then
- Set_Etype (Desig_Type,
+ Set_Etype (Desig_Type,
Create_Null_Excluding_Itype
(T => Typ,
Related_Nod => T_Def,
Full_Desig : Entity_Id;
begin
- Check_SPARK_Restriction ("access type is not allowed", Def);
+ Check_SPARK_05_Restriction ("access type is not allowed", Def);
-- Check for permissible use of incomplete type
if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
Set_Directly_Designated_Type (T, Entity (S));
+
+ -- If the designated type is a limited view, we cannot tell if
+ -- the full view contains tasks, and there is no way to handle
+ -- that full view in a client. We create a master entity for the
+ -- scope, which will be used when a client determines that one
+ -- is needed.
+
+ if From_Limited_With (Entity (S))
+ and then not Is_Class_Wide_Type (Entity (S))
+ then
+ Set_Ekind (T, E_Access_Type);
+ Build_Master_Entity (T);
+ Build_Master_Renaming (T);
+ end if;
+
else
- Set_Directly_Designated_Type (T,
- Process_Subtype (S, P, T, 'P'));
+ Set_Directly_Designated_Type (T, Process_Subtype (S, P, T, 'P'));
end if;
-- If the access definition is of the form: ACCESS NOT NULL ..
Set_Etype (New_Subp, Etype (Iface_Prim));
end if;
- -- Internal entities associated with interface types are
- -- only registered in the list of primitives of the tagged
- -- type. They are only used to fill the contents of the
- -- secondary dispatch tables. Therefore they are not needed
- -- in the homonym chains.
+ -- Internal entities associated with interface types are only
+ -- registered in the list of primitives of the tagged type.
+ -- They are only used to fill the contents of the secondary
+ -- dispatch tables. Therefore they are not needed in the
+ -- homonym chains.
Remove_Homonym (New_Subp);
-- Hidden entities associated with interfaces must have set
- -- the Has_Delay_Freeze attribute to ensure that, in case of
- -- locally defined tagged types (or compiling with static
+ -- the Has_Delay_Freeze attribute to ensure that, in case
+ -- of locally defined tagged types (or compiling with static
-- dispatch tables generation disabled) the corresponding
- -- entry of the secondary dispatch table is filled when
- -- such an entity is frozen.
+ -- entry of the secondary dispatch table is filled when such
+ -- an entity is frozen. This is an expansion activity that must
+ -- be suppressed for ASIS because it leads to gigi elaboration
+ -- issues in annotate mode.
- Set_Has_Delayed_Freeze (New_Subp);
+ if not ASIS_Mode then
+ Set_Has_Delayed_Freeze (New_Subp);
+ end if;
end if;
<<Continue>>
-----------------------------------
procedure Analyze_Component_Declaration (N : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (N);
- E : constant Node_Id := Expression (N);
- Typ : constant Node_Id :=
+ Loc : constant Source_Ptr := Sloc (Component_Definition (N));
+ Id : constant Entity_Id := Defining_Identifier (N);
+ E : constant Node_Id := Expression (N);
+ Typ : constant Node_Id :=
Subtype_Indication (Component_Definition (N));
T : Entity_Id;
P : Entity_Id;
(Subtype_Indication (Component_Definition (N)), N);
if not Nkind_In (Typ, N_Identifier, N_Expanded_Name) then
- Check_SPARK_Restriction ("subtype mark required", Typ);
+ Check_SPARK_05_Restriction ("subtype mark required", Typ);
end if;
-- Ada 2005 (AI-230): Access Definition case
-- package Sem).
if Present (E) then
- Check_SPARK_Restriction ("default expression is not allowed", E);
- Preanalyze_Spec_Expression (E, T);
+ Check_SPARK_05_Restriction ("default expression is not allowed", E);
+ Preanalyze_Default_Expression (E, T);
Check_Initialization (T, E);
if Ada_Version >= Ada_2005
end if;
end if;
+ -- If the component is an unconstrained task or protected type with
+ -- discriminants, the component and the enclosing record are limited
+ -- and the component is constrained by its default values. Compute
+ -- its actual subtype, else it may be allocated the maximum size by
+ -- the backend, and possibly overflow.
+
+ if Is_Concurrent_Type (T)
+ and then not Is_Constrained (T)
+ and then Has_Discriminants (T)
+ and then not Has_Discriminants (Current_Scope)
+ then
+ declare
+ Act_T : constant Entity_Id := Build_Default_Subtype (T, N);
+
+ begin
+ Set_Etype (Id, Act_T);
+
+ -- Rewrite component definition to use the constrained subtype
+
+ Rewrite (Component_Definition (N),
+ Make_Component_Definition (Loc,
+ Subtype_Indication => New_Occurrence_Of (Act_T, Loc)));
+ end;
+ end if;
+
Set_Original_Record_Component (Id, Id);
if Has_Aspects (N) then
Parameter_Specifications (Body_Spec);
Spec : Node_Id;
Spec_Id : Entity_Id;
-
- Dummy : Entity_Id;
- -- A dummy variable used to capture the unused result of subprogram
- -- spec analysis.
+ Typ : Node_Id;
begin
-- Consider only procedure bodies whose name matches one of the three
then
return;
- -- A controlled primitive must have exactly one formal
+ -- A controlled primitive must have exactly one formal which is not
+ -- an anonymous access type.
elsif List_Length (Params) /= 1 then
return;
end if;
- Dummy := Analyze_Subprogram_Specification (Body_Spec);
-
- -- The type of the formal must be derived from [Limited_]Controlled
+ Typ := Parameter_Type (First (Params));
- if not Is_Controlled (Etype (Defining_Entity (First (Params)))) then
+ if Nkind (Typ) = N_Access_Definition then
return;
end if;
- Spec_Id := Find_Corresponding_Spec (Body_Decl, Post_Error => False);
+ Find_Type (Typ);
- -- The body has a matching spec, therefore it cannot be a late
- -- primitive.
+ -- The type of the formal must be derived from [Limited_]Controlled
- if Present (Spec_Id) then
+ if not Is_Controlled (Entity (Typ)) then
return;
end if;
+ -- Check whether a specification exists for this body. We do not
+ -- analyze the spec of the body in full, because it will be analyzed
+ -- again when the body is properly analyzed, and we cannot create
+ -- duplicate entries in the formals chain. We look for an explicit
+ -- specification because the body may be an overriding operation and
+ -- an inherited spec may be present.
+
+ Spec_Id := Current_Entity (Body_Id);
+
+ while Present (Spec_Id) loop
+ if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure)
+ and then Scope (Spec_Id) = Current_Scope
+ and then Present (First_Formal (Spec_Id))
+ and then No (Next_Formal (First_Formal (Spec_Id)))
+ and then Etype (First_Formal (Spec_Id)) = Entity (Typ)
+ and then Comes_From_Source (Spec_Id)
+ then
+ return;
+ end if;
+
+ Spec_Id := Homonym (Spec_Id);
+ end loop;
+
-- At this point the body is known to be a late controlled primitive.
-- Generate a matching spec and insert it before the body. Note the
-- use of Copy_Separate_Tree - we want an entirely separate semantic
Set_Null_Present (Spec, False);
Insert_Before_And_Analyze (Body_Decl,
- Make_Subprogram_Declaration (Loc,
- Specification => Spec));
+ Make_Subprogram_Declaration (Loc, Specification => Spec));
end Handle_Late_Controlled_Primitive;
--------------------------------
-- Local variables
- Context : Node_Id;
+ Context : Node_Id := Empty;
Freeze_From : Entity_Id := Empty;
Next_Decl : Node_Id;
- Spec_Id : Entity_Id;
+ Pack_Decl : Node_Id := Empty;
Body_Seen : Boolean := False;
-- Flag set when the first body [stub] is encountered
- In_Package_Body : Boolean := False;
- -- Flag set when the current declaration list belongs to a package body
-
-- Start of processing for Analyze_Declarations
begin
if Nkind (Decl) = N_Package_Declaration
and then Nkind (Parent (L)) = N_Package_Specification
then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("package specification cannot contain a package declaration",
Decl);
end if;
Context := Parent (L);
if Nkind (Context) = N_Package_Specification then
+ Pack_Decl := Parent (Context);
-- When a package has private declarations, its contract must be
-- analyzed at the end of the said declarations. This way both the
if L = Private_Declarations (Context) then
Analyze_Package_Contract (Defining_Entity (Context));
+ -- Build the bodies of the default initial condition procedures
+ -- for all types subject to pragma Default_Initial_Condition.
+ -- From a purely Ada stand point, this is a freezing activity,
+ -- however freezing is not available under GNATprove_Mode. To
+ -- accomodate both scenarios, the bodies are build at the end
+ -- of private declaration analysis.
+
+ Build_Default_Init_Cond_Procedure_Bodies (L);
+
-- Otherwise the contract is analyzed at the end of the visible
-- declarations.
end if;
elsif Nkind (Context) = N_Package_Body then
- In_Package_Body := True;
- Spec_Id := Corresponding_Spec (Context);
-
+ Pack_Decl := Context;
Analyze_Package_Body_Contract (Defining_Entity (Context));
end if;
- end if;
- -- Analyze the contracts of subprogram declarations, subprogram bodies
- -- and variables now due to the delayed visibility requirements of their
- -- aspects.
+ -- Analyze the contracts of all subprogram declarations, subprogram
+ -- bodies and variables now due to the delayed visibility needs of
+ -- of their aspects and pragmas. Capture global references in generic
+ -- subprograms or bodies.
- Decl := First (L);
- while Present (Decl) loop
- if Nkind (Decl) = N_Object_Declaration then
- Analyze_Object_Contract (Defining_Entity (Decl));
+ Decl := First (L);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Object_Declaration then
+ Analyze_Object_Contract (Defining_Entity (Decl));
- elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
- N_Subprogram_Declaration)
- then
- Analyze_Subprogram_Contract (Defining_Entity (Decl));
+ elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Subprogram_Declaration)
+ then
+ Analyze_Subprogram_Contract (Defining_Entity (Decl));
- elsif Nkind (Decl) = N_Subprogram_Body then
- Analyze_Subprogram_Body_Contract (Defining_Entity (Decl));
+ elsif Nkind (Decl) = N_Subprogram_Body then
+ Analyze_Subprogram_Body_Contract (Defining_Entity (Decl));
- elsif Nkind (Decl) = N_Subprogram_Body_Stub then
- Analyze_Subprogram_Body_Stub_Contract (Defining_Entity (Decl));
- end if;
+ elsif Nkind (Decl) = N_Subprogram_Body_Stub then
+ Analyze_Subprogram_Body_Stub_Contract (Defining_Entity (Decl));
+ end if;
- Next (Decl);
- end loop;
+ -- Capture all global references in a generic subprogram or a body
+ -- [stub] now that the contract has been analyzed.
- -- State refinements are visible upto the end the of the package body
- -- declarations. Hide the refinements from visibility to restore the
- -- original state conditions.
+ if Nkind_In (Decl, N_Generic_Subprogram_Declaration,
+ N_Subprogram_Body,
+ N_Subprogram_Body_Stub)
+ and then Is_Generic_Declaration_Or_Body (Decl)
+ then
+ Save_Global_References_In_Contract
+ (Templ => Original_Node (Decl),
+ Gen_Id => Corresponding_Spec_Of (Decl));
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- The owner of the declarations is a package [body]
+
+ if Present (Pack_Decl) then
+
+ -- Capture all global references in a generic package or a body
+ -- after all nested generic subprograms and bodies were subjected
+ -- to the same processing.
+
+ if Is_Generic_Declaration_Or_Body (Pack_Decl) then
+ Save_Global_References_In_Contract
+ (Templ => Original_Node (Pack_Decl),
+ Gen_Id => Corresponding_Spec_Of (Pack_Decl));
+ end if;
+
+ -- State refinements are visible upto the end the of the package
+ -- body declarations. Hide the state refinements from visibility
+ -- to restore the original state conditions.
- if In_Package_Body then
- Remove_Visible_Refinements (Spec_Id);
+ if Nkind (Pack_Decl) = N_Package_Body then
+ Remove_Visible_Refinements (Corresponding_Spec (Pack_Decl));
+ end if;
+ end if;
end if;
end Analyze_Declarations;
begin
Prev := Find_Type_Name (N);
- -- The full view, if present, now points to the current type
- -- If there is an incomplete partial view, set a link to it, to
- -- simplify the retrieval of primitive operations of the type.
+ -- The type declaration may be subject to pragma Ghost with policy
+ -- Ignore. Set the mode now to ensure that any nodes generated during
+ -- analysis and expansion are properly flagged as ignored Ghost.
+
+ Set_Ghost_Mode (N, Prev);
+
+ -- The full view, if present, now points to the current type. If there
+ -- is an incomplete partial view, set a link to it, to simplify the
+ -- retrieval of primitive operations of the type.
-- Ada 2005 (AI-50217): If the type was previously decorated when
-- imported through a LIMITED WITH clause, it appears as incomplete
-- but has no full view.
- if Ekind (Prev) = E_Incomplete_Type and then Present (Full_View (Prev))
+ if Ekind (Prev) = E_Incomplete_Type
+ and then Present (Full_View (Prev))
then
T := Full_View (Prev);
Set_Incomplete_View (N, Parent (Prev));
when N_Record_Definition =>
if Present (Discriminant_Specifications (N)) then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("discriminant type is not allowed",
Defining_Identifier
(First (Discriminant_Specifications (N))));
Set_Analyzed (T);
case Nkind (Def) is
-
when N_Access_To_Subprogram_Definition =>
Access_Subprogram_Declaration (T, Def);
Add_RACW_Features (Def_Id);
end if;
- -- Set no strict aliasing flag if config pragma seen
-
- if Opt.No_Strict_Aliasing then
- Set_No_Strict_Aliasing (Base_Type (Def_Id));
- end if;
-
when N_Array_Type_Definition =>
Array_Type_Declaration (T, Def);
-- Controlled type is not allowed in SPARK
if Is_Visibly_Controlled (T) then
- Check_SPARK_Restriction ("controlled type is not allowed", N);
+ Check_SPARK_05_Restriction ("controlled type is not allowed", N);
+ end if;
+
+ -- A type declared within a Ghost region is automatically Ghost
+ -- (SPARK RM 6.9(2)).
+
+ if Comes_From_Source (T) and then Ghost_Mode > None then
+ Set_Is_Ghost_Entity (T);
end if;
-- Some common processing for all types
Set_Depends_On_Private (T, Has_Private_Component (T));
Check_Ops_From_Incomplete_Type;
- -- Both the declared entity, and its anonymous base type if one
- -- was created, need freeze nodes allocated.
+ -- Both the declared entity, and its anonymous base type if one was
+ -- created, need freeze nodes allocated.
declare
B : constant Entity_Id := Base_Type (T);
Generate_Definition (Def_Id);
end if;
+ -- Propagate any pending access types whose finalization masters need to
+ -- be fully initialized from the partial to the full view. Guard against
+ -- an illegal full view that remains unanalyzed.
+
+ if Is_Type (Def_Id) and then Is_Incomplete_Or_Private_Type (Prev) then
+ Set_Pending_Access_Types (Def_Id, Pending_Access_Types (Prev));
+ end if;
+
if Chars (Scope (Def_Id)) = Name_System
and then Chars (Def_Id) = Name_Address
and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
-- view, but which is the one that will be frozen.
if Has_Aspects (N) then
- if Prev /= Def_Id then
+
+ -- In most cases the partial view is a private type, and both views
+ -- appear in different declarative parts. In the unusual case where
+ -- the partial view is incomplete, perform the analysis on the
+ -- full view, to prevent freezing anomalies with the corresponding
+ -- class-wide type, which otherwise might be frozen before the
+ -- dispatch table is built.
+
+ if Prev /= Def_Id
+ and then Ekind (Prev) /= E_Incomplete_Type
+ then
Analyze_Aspect_Specifications (N, Prev);
+
+ -- Normal case
+
else
Analyze_Aspect_Specifications (N, Def_Id);
end if;
T : Entity_Id;
begin
- Check_SPARK_Restriction ("incomplete type is not allowed", N);
+ Check_SPARK_05_Restriction ("incomplete type is not allowed", N);
Generate_Definition (Defining_Identifier (N));
Set_Is_First_Subtype (T, True);
Set_Etype (T, T);
+ -- An incomplete type declared within a Ghost region is automatically
+ -- Ghost (SPARK RM 6.9(2)).
+
+ if Ghost_Mode > None then
+ Set_Is_Ghost_Entity (T);
+ end if;
+
-- Ada 2005 (AI-326): Minimum decoration to give support to tagged
-- incomplete types.
if Tagged_Present (N) then
- Set_Is_Tagged_Type (T);
+ Set_Is_Tagged_Type (T, True);
+ Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams);
Make_Class_Wide_Type (T);
Set_Direct_Primitive_Operations (T, New_Elmt_List);
end if;
begin
Set_Is_Tagged_Type (T);
+ Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams);
Set_Is_Limited_Record (T, Limited_Present (Def)
or else Task_Present (Def)
It : Interp;
begin
+ -- The number declaration may be subject to pragma Ghost with policy
+ -- Ignore. Set the mode now to ensure that any nodes generated during
+ -- analysis and expansion are properly flagged as ignored Ghost.
+
+ Set_Ghost_Mode (N);
+
Generate_Definition (Id);
Enter_Name (Id);
+ -- A number declared within a Ghost region is automatically Ghost
+ -- (SPARK RM 6.9(2)).
+
+ if Ghost_Mode > None then
+ Set_Is_Ghost_Entity (Id);
+ end if;
+
-- This is an optimization of a common case of an integer literal
if Nkind (E) = N_Integer_Literal then
if not Is_Overloaded (E) then
T := Etype (E);
+ if Has_Dynamic_Predicate_Aspect (T) then
+ Error_Msg_N
+ ("subtype has dynamic predicate, "
+ & "not allowed in number declaration", N);
+ end if;
else
T := Any_Type;
T := It.Typ;
elsif It.Typ = Universal_Real
- or else It.Typ = Universal_Integer
+ or else
+ It.Typ = Universal_Integer
then
-- Choose universal interpretation over any other
Seen : Boolean := False;
begin
+ -- The loop parameter in an element iterator over a formal container
+ -- is declared with an object declaration but no contracts apply.
+
+ if Ekind (Obj_Id) = E_Loop_Parameter then
+ return;
+ end if;
+
+ -- Constant related checks
+
if Ekind (Obj_Id) = E_Constant then
-- A constant cannot be effectively volatile. This check is only
if SPARK_Mode = On
and then Is_Effectively_Volatile (Obj_Id)
and then No (Corresponding_Generic_Association (Parent (Obj_Id)))
+
+ -- Don't give this for internally generated entities (such as the
+ -- FIRST and LAST temporaries generated for bounds).
+
+ and then Comes_From_Source (Obj_Id)
then
Error_Msg_N ("constant cannot be volatile", Obj_Id);
end if;
+ -- Variable related checks
+
else pragma Assert (Ekind (Obj_Id) = E_Variable);
-- The following checks are only relevant when SPARK_Mode is on as
end if;
end if;
+ if Is_Ghost_Entity (Obj_Id) then
+
+ -- A Ghost object cannot be effectively volatile (SPARK RM 6.9(8))
+
+ if Is_Effectively_Volatile (Obj_Id) then
+ Error_Msg_N ("ghost variable & cannot be volatile", Obj_Id);
+
+ -- A Ghost object cannot be imported or exported (SPARK RM 6.9(8))
+
+ elsif Is_Imported (Obj_Id) then
+ Error_Msg_N ("ghost object & cannot be imported", Obj_Id);
+
+ elsif Is_Exported (Obj_Id) then
+ Error_Msg_N ("ghost object & cannot be exported", Obj_Id);
+ end if;
+ end if;
+
-- Analyze all external properties
Prag := Get_Pragma (Obj_Id, Pragma_Async_Readers);
if Seen then
Check_External_Properties (Obj_Id, AR_Val, AW_Val, ER_Val, EW_Val);
end if;
+ end if;
+
+ -- Check whether the lack of indicator Part_Of agrees with the placement
+ -- of the object with respect to the state space.
+
+ Prag := Get_Pragma (Obj_Id, Pragma_Part_Of);
- -- Check whether the lack of indicator Part_Of agrees with the
- -- placement of the variable with respect to the state space.
+ if No (Prag) then
+ Check_Missing_Part_Of (Obj_Id);
+ end if;
+
+ -- A ghost object cannot be imported or exported (SPARK RM 6.9(8))
- Prag := Get_Pragma (Obj_Id, Pragma_Part_Of);
+ if Is_Ghost_Entity (Obj_Id) then
+ if Is_Exported (Obj_Id) then
+ Error_Msg_N ("ghost object & cannot be exported", Obj_Id);
- if No (Prag) then
- Check_Missing_Part_Of (Obj_Id);
+ elsif Is_Imported (Obj_Id) then
+ Error_Msg_N ("ghost object & cannot be imported", Obj_Id);
end if;
end if;
end Analyze_Object_Contract;
-- or a variant record type is encountered, Check_Restrictions is called
-- indicating the count is unknown.
+ function Delayed_Aspect_Present return Boolean;
+ -- If the declaration has an expression that is an aggregate, and it
+ -- has aspects that require delayed analysis, the resolution of the
+ -- aggregate must be deferred to the freeze point of the objet. This
+ -- special processing was created for address clauses, but it must
+ -- also apply to Alignment. This must be done before the aspect
+ -- specifications are analyzed because we must handle the aggregate
+ -- before the analysis of the object declaration is complete.
+
+ -- Any other relevant delayed aspects on object declarations ???
+
-----------------
-- Count_Tasks --
-----------------
end if;
end Count_Tasks;
+ ----------------------------
+ -- Delayed_Aspect_Present --
+ ----------------------------
+
+ function Delayed_Aspect_Present return Boolean is
+ A : Node_Id;
+ A_Id : Aspect_Id;
+
+ begin
+ if Present (Aspect_Specifications (N)) then
+ A := First (Aspect_Specifications (N));
+ A_Id := Get_Aspect_Id (Chars (Identifier (A)));
+ while Present (A) loop
+ if A_Id = Aspect_Alignment or else A_Id = Aspect_Address then
+ return True;
+ end if;
+
+ Next (A);
+ end loop;
+ end if;
+
+ return False;
+ end Delayed_Aspect_Present;
+
-- Start of processing for Analyze_Object_Declaration
begin
-- Enter_Name will handle the visibility.
or else
- (Is_Discriminal (Id)
+ (Is_Discriminal (Id)
and then Ekind (Discriminal_Link (Id)) =
- E_Entry_Index_Parameter)
+ E_Entry_Index_Parameter)
-- The current object is the renaming for a generic declared
-- within the instance.
or else
- (Ekind (Prev_Entity) = E_Package
- and then Nkind (Parent (Prev_Entity)) =
- N_Package_Renaming_Declaration
- and then not Comes_From_Source (Prev_Entity)
- and then Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
+ (Ekind (Prev_Entity) = E_Package
+ and then Nkind (Parent (Prev_Entity)) =
+ N_Package_Renaming_Declaration
+ and then not Comes_From_Source (Prev_Entity)
+ and then
+ Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
then
Prev_Entity := Empty;
end if;
end if;
+ -- The object declaration may be subject to pragma Ghost with policy
+ -- Ignore. Set the mode now to ensure that any nodes generated during
+ -- analysis and expansion are properly flagged as ignored Ghost.
+
+ Set_Ghost_Mode (N, Prev_Entity);
+
if Present (Prev_Entity) then
Constant_Redeclaration (Id, N, T);
end if;
end if;
- -- If not a deferred constant, then object declaration freezes its type
+ -- If not a deferred constant, then the object declaration freezes
+ -- its type, unless the object is of an anonymous type and has delayed
+ -- aspects. In that case the type is frozen when the object itself is.
else
Check_Fully_Declared (T, N);
- Freeze_Before (N, T);
+
+ if Has_Delayed_Aspects (Id)
+ and then Is_Array_Type (T)
+ and then Is_Itype (T)
+ then
+ Set_Has_Delayed_Freeze (T);
+ else
+ Freeze_Before (N, T);
+ end if;
end if;
-- If the object was created by a constrained array definition, then
-- and must not be unconstrained. (The only exception to this is the
-- acceptance of declarations of constants of type String.)
- if not
- Nkind_In (Object_Definition (N), N_Identifier, N_Expanded_Name)
+ if not Nkind_In (Object_Definition (N), N_Expanded_Name, N_Identifier)
then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("subtype mark required", Object_Definition (N));
elsif Is_Array_Type (T)
and then not Is_Constrained (T)
and then T /= Standard_String
then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("subtype mark of constrained type expected",
Object_Definition (N));
end if;
-- There are no aliased objects in SPARK
if Aliased_Present (N) then
- Check_SPARK_Restriction ("aliased object is not allowed", N);
+ Check_SPARK_05_Restriction ("aliased object is not allowed", N);
end if;
-- Process initialization expression if present and not in error
if Comes_From_Source (N)
and then Expander_Active
- and then Has_Following_Address_Clause (N)
and then Nkind (E) = N_Aggregate
+ and then (Present (Following_Address_Clause (N))
+ or else Delayed_Aspect_Present)
then
Set_Etype (E, T);
and then Is_Access_Constant (Etype (E))
then
Error_Msg_N
- ("access to variable cannot be initialized "
- & "with an access-to-constant expression", E);
+ ("access to variable cannot be initialized with an "
+ & "access-to-constant expression", E);
end if;
if not Assignment_OK (N) then
-- Only call test if needed
and then Restriction_Check_Required (SPARK_05)
- and then not Is_SPARK_Initialization_Expr (Original_Node (E))
+ and then not Is_SPARK_05_Initialization_Expr (Original_Node (E))
then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("initialization expression is not appropriate", E);
end if;
+
+ -- A formal parameter of a specific tagged type whose related
+ -- subprogram is subject to pragma Extensions_Visible with value
+ -- "False" cannot be implicitly converted to a class-wide type by
+ -- means of an initialization expression (SPARK RM 6.1.7(3)).
+
+ if Is_Class_Wide_Type (T) and then Is_EVF_Expression (E) then
+ Error_Msg_N
+ ("formal parameter with Extensions_Visible False cannot be "
+ & "implicitly converted to class-wide type", E);
+ end if;
end if;
-- If the No_Streams restriction is set, check that the type of the
-- only for constants of type string.
if Is_String_Type (T) and then not Constant_Present (N) then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("declaration of object of unconstrained type not allowed", N);
end if;
elsif Is_Interface (T) then
null;
+ -- In GNATprove mode, Expand_Subtype_From_Expr does nothing. Thus,
+ -- we should prevent the generation of another Itype with the
+ -- same name as the one already generated, or we end up with
+ -- two identical types in GNATprove.
+
+ elsif GNATprove_Mode then
+ null;
+
+ -- If the type is an unchecked union, no subtype can be built from
+ -- the expression. Rewrite declaration as a renaming, which the
+ -- back-end can handle properly. This is a rather unusual case,
+ -- because most unchecked_union declarations have default values
+ -- for discriminants and are thus not indefinite.
+
+ elsif Is_Unchecked_Union (T) then
+ if Constant_Present (N) or else Nkind (E) = N_Function_Call then
+ Set_Ekind (Id, E_Constant);
+ else
+ Set_Ekind (Id, E_Variable);
+ end if;
+
+ -- An object declared within a Ghost region is automatically
+ -- Ghost (SPARK RM 6.9(2)).
+
+ if Comes_From_Source (Id) and then Ghost_Mode > None then
+ Set_Is_Ghost_Entity (Id);
+
+ -- The Ghost policy in effect at the point of declaration
+ -- and at the point of completion must match
+ -- (SPARK RM 6.9(14)).
+
+ if Present (Prev_Entity)
+ and then Is_Ghost_Entity (Prev_Entity)
+ then
+ Check_Ghost_Completion (Prev_Entity, Id);
+ end if;
+ end if;
+
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Id,
+ Subtype_Mark => New_Occurrence_Of (T, Loc),
+ Name => E));
+
+ Set_Renamed_Object (Id, E);
+ Freeze_Before (N, T);
+ Set_Is_Frozen (Id);
+ return;
+
else
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
-- true for variables so far (will be reset for a variable if and when
-- we encounter a modification in the source).
- Set_Never_Set_In_Source (Id, True);
+ Set_Never_Set_In_Source (Id);
-- Now establish the proper kind and type of the object
-- the case of exception choice variables, it will already be true).
if Present (E) then
- Set_Has_Initial_Value (Id, True);
+ Set_Has_Initial_Value (Id);
end if;
-
- Set_Contract (Id, Make_Contract (Sloc (Id)));
end if;
-- Initialize alignment and size and capture alignment setting
Init_Esize (Id);
Set_Optimize_Alignment_Flags (Id);
+ -- An object declared within a Ghost region is automatically Ghost
+ -- (SPARK RM 6.9(2)).
+
+ if Comes_From_Source (Id)
+ and then (Ghost_Mode > None
+ or else (Present (Prev_Entity)
+ and then Is_Ghost_Entity (Prev_Entity)))
+ then
+ Set_Is_Ghost_Entity (Id);
+
+ -- The Ghost policy in effect at the point of declaration and at the
+ -- point of completion must match (SPARK RM 6.9(14)).
+
+ if Present (Prev_Entity) and then Is_Ghost_Entity (Prev_Entity) then
+ Check_Ghost_Completion (Prev_Entity, Id);
+ end if;
+ end if;
+
-- Deal with aliased case
if Aliased_Present (N) then
Set_Etype (Id, Act_T);
- -- Object is marked to be treated as volatile if type is volatile and
- -- we clear the Current_Value setting that may have been set above.
+ -- Non-constant object is marked to be treated as volatile if type is
+ -- volatile and we clear the Current_Value setting that may have been
+ -- set above. Doing so for constants isn't required and might interfere
+ -- with possible uses of the object as a static expression in contexts
+ -- incompatible with volatility (e.g. as a case-statement alternative).
- if Treat_As_Volatile (Etype (Id)) then
+ if Ekind (Id) /= E_Constant and then Treat_As_Volatile (Etype (Id)) then
Set_Treat_As_Volatile (Id);
Set_Current_Value (Id, Empty);
end if;
Parent_Base : Entity_Id;
begin
+ -- The private extension declaration may be subject to pragma Ghost with
+ -- policy Ignore. Set the mode now to ensure that any nodes generated
+ -- during analysis and expansion are properly flagged as ignored Ghost.
+
+ Set_Ghost_Mode (N);
+
-- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
if Is_Non_Empty_List (Interface_List (N)) then
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
+ if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type then
Set_Ekind (T, Ekind (Parent_Type));
Set_Etype (T, Any_Type);
goto Leave;
R_Checks : Check_Result;
begin
+ -- The subtype declaration may be subject to pragma Ghost with policy
+ -- Ignore. Set the mode now to ensure that any nodes generated during
+ -- analysis and expansion are properly flagged as ignored Ghost.
+
+ Set_Ghost_Mode (N);
+
Generate_Definition (Id);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
Init_Size_Align (Id);
if Is_Boolean_Type (T)
and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication
then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("subtype of Boolean cannot have constraint", N);
end if;
if not
Nkind_In (One_Cstr, N_Identifier, N_Expanded_Name)
then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("subtype mark required", One_Cstr);
-- String subtype must have a lower bound of 1 in SPARK.
if Is_OK_Static_Expression (Low)
and then Expr_Value (Low) /= 1
then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("String subtype must have lower bound of 1", N);
end if;
end if;
-- in SPARK.
if Is_Array_Type (T) and then not Is_Constrained (T) then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("subtype of unconstrained array must have constraint", N);
end if;
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);
+ Set_No_Tagged_Streams_Pragma
+ (Id, No_Tagged_Streams_Pragma (T));
if Ekind (T) = E_Class_Wide_Subtype then
Set_Equivalent_Type (Id, Equivalent_Type (T));
end if;
if Is_Tagged_Type (T) then
- Set_Is_Tagged_Type (Id);
+ Set_Is_Tagged_Type (Id, True);
+ Set_No_Tagged_Streams_Pragma
+ (Id, No_Tagged_Streams_Pragma (T));
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
Set_Direct_Primitive_Operations
(Id, Direct_Primitive_Operations (T));
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
+ Set_No_Tagged_Streams_Pragma (Id,
+ No_Tagged_Streams_Pragma (T));
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Direct_Primitive_Operations (Id,
Set_Is_Tagged_Type (Id, Is_Tagged_Type (T));
Set_Last_Entity (Id, Last_Entity (T));
+ if Is_Tagged_Type (T) then
+ Set_No_Tagged_Streams_Pragma
+ (Id, No_Tagged_Streams_Pragma (T));
+ end if;
+
if Has_Discriminants (T) then
- Set_Discriminant_Constraint (Id,
- Discriminant_Constraint (T));
+ Set_Discriminant_Constraint
+ (Id, Discriminant_Constraint (T));
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
end if;
- when E_Incomplete_Type =>
+ when Incomplete_Kind =>
if Ada_Version >= Ada_2005 then
-- In Ada 2005 an incomplete type can be explicitly tagged:
- -- propagate indication.
+ -- propagate indication. Note that we also have to include
+ -- subtypes for Ada 2012 extended use of incomplete types.
Set_Ekind (Id, E_Incomplete_Subtype);
Set_Is_Tagged_Type (Id, Is_Tagged_Type (T));
Set_Private_Dependents (Id, New_Elmt_List);
+ if Is_Tagged_Type (Id) then
+ Set_No_Tagged_Streams_Pragma
+ (Id, No_Tagged_Streams_Pragma (T));
+ Set_Direct_Primitive_Operations (Id, New_Elmt_List);
+ end if;
+
-- Ada 2005 (AI-412): Decorate an incomplete subtype of an
-- incomplete type visible through a limited with clause.
and then
(Nkind (Parent (Generic_Parent_Type (N))) /=
N_Formal_Type_Declaration
- or else Nkind
- (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) /=
+ or else Nkind (Formal_Type_Definition
+ (Parent (Generic_Parent_Type (N)))) /=
N_Formal_Private_Type_Definition)
then
if Is_Tagged_Type (Id) then
end if;
end if;
+ -- A type invariant applies to any subtype in its scope, in particular
+ -- to a generic actual.
+
+ if Has_Invariants (T) and then In_Open_Scopes (Scope (T)) then
+ Set_Has_Invariants (Id);
+ Set_Invariant_Procedure (Id, Invariant_Procedure (T));
+ end if;
+
-- Make sure that generic actual types are properly frozen. The subtype
-- is marked as a generic actual type when the enclosing instance is
-- analyzed, so here we identify the subtype from the tree structure.
-- Check SPARK restriction requiring a subtype mark
if not Nkind_In (Index, N_Identifier, N_Expanded_Name) then
- Check_SPARK_Restriction ("subtype mark required", Index);
+ Check_SPARK_05_Restriction ("subtype mark required", Index);
end if;
-- Add a subtype declaration for each index of private array type
Set_Etype (Component_Typ, Element_Type);
if not Nkind_In (Component_Typ, N_Identifier, N_Expanded_Name) then
- Check_SPARK_Restriction ("subtype mark required", Component_Typ);
+ Check_SPARK_05_Restriction
+ ("subtype mark required", Component_Typ);
end if;
-- Ada 2005 (AI-230): Access Definition case
-- The constrained array type is a subtype of the unconstrained one
- 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_Ekind (T, E_Array_Subtype);
+ Init_Size_Align (T);
+ Set_Etype (T, Implicit_Base);
+ Set_Scope (T, Current_Scope);
+ Set_Is_Constrained (T);
+ Set_First_Index (T,
+ First (Discrete_Subtype_Definitions (Def)));
Set_Has_Delayed_Freeze (T);
-- Complete setup of implicit base type
Set_Has_Protected (Implicit_Base, Has_Protected (Element_Type));
Set_Component_Size (Implicit_Base, Uint_0);
Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
- 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));
+
+ -- Inherit the "ghostness" from the constrained array type
+
+ if Is_Ghost_Entity (T) or else Ghost_Mode > None then
+ Set_Is_Ghost_Entity (Implicit_Base);
+ end if;
-- Unconstrained array case
Set_Packed_Array_Impl_Type (T, Empty);
if Aliased_Present (Component_Definition (Def)) then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("aliased is not allowed", Component_Definition (Def));
Set_Has_Aliased_Components (Etype (T));
end if;
Set_Scope (Typ, Current_Scope);
Push_Scope (Typ);
- Process_Formals (Parameter_Specifications (Spec), Spec);
+ -- Nothing to do if procedure is parameterless
+
+ if Present (Parameter_Specifications (Spec)) then
+ Process_Formals (Parameter_Specifications (Spec), Spec);
+ end if;
if Nkind (Spec) = N_Access_Function_Definition then
declare
Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
Set_Has_Delayed_Freeze (Implicit_Base, True);
+
+ -- Inherit the "ghostness" from the parent base type
+
+ if Is_Ghost_Entity (Parent_Base) or else Ghost_Mode > None then
+ Set_Is_Ghost_Entity (Implicit_Base);
+ end if;
end Make_Implicit_Base;
-- Start of processing for Build_Derived_Array_Type
Insert_Before (N, Type_Decl);
Analyze (Type_Decl);
+ -- The anonymous base now has a full declaration, but this base
+ -- is not a first subtype.
+
+ Set_Is_First_Subtype (Implicit_Base, False);
+
-- After the implicit base is analyzed its Etype needs to be changed
-- to reflect the fact that it is derived from the parent type which
-- was ignored during analysis. We also set the size at this point.
Analyze (N);
+ -- Propagate the aspects from the original type declaration to the
+ -- declaration of the implicit base.
+
+ Move_Aspects (From => Original_Node (N), To => Type_Decl);
+
-- Apply a range check. Since this range expression doesn't have an
-- Etype, we have to specifically pass the Source_Typ parameter. Is
-- this right???
if Nkind (Indic) = N_Subtype_Indication then
- Apply_Range_Check (Range_Expression (Constraint (Indic)),
- Parent_Type,
- Source_Typ => Entity (Subtype_Mark (Indic)));
+ Apply_Range_Check
+ (Range_Expression (Constraint (Indic)), Parent_Type,
+ Source_Typ => Entity (Subtype_Mark (Indic)));
end if;
end if;
end Build_Derived_Enumeration_Type;
-- If we did not have a range constraint, then set the range from the
-- parent type. Otherwise, the Process_Subtype call has set the bounds.
- if No_Constraint
- or else not Has_Range_Constraint (Indic)
- then
+ 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)),
Is_Completion : Boolean;
Derive_Subps : Boolean := True)
is
- Loc : constant Source_Ptr := Sloc (N);
- 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;
+ Loc : constant Source_Ptr := Sloc (N);
+ Par_Base : constant Entity_Id := Base_Type (Parent_Type);
+ Par_Scope : constant Entity_Id := Scope (Par_Base);
+ Full_N : constant Node_Id := New_Copy_Tree (N);
+ Full_Der : Entity_Id := New_Copy (Derived_Type);
+ Full_P : Entity_Id;
+
+ procedure Build_Full_Derivation;
+ -- Build full derivation, i.e. derive from the full view
procedure Copy_And_Build;
-- Copy derived type declaration, replace parent with its full view,
- -- and analyze new declaration.
+ -- and build derivation
+
+ ---------------------------
+ -- Build_Full_Derivation --
+ ---------------------------
+
+ procedure Build_Full_Derivation is
+ begin
+ -- If parent scope is not open, install the declarations
+
+ 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);
+
+ -- If parent scope is open and in another unit, and parent has a
+ -- completion, then the derivation is taking place in the visible
+ -- part of a child unit. In that case retrieve the full view of
+ -- the parent momentarily.
+
+ 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);
+
+ -- Otherwise it is a local derivation
+
+ else
+ Copy_And_Build;
+ end if;
+ end Build_Full_Derivation;
--------------------
-- Copy_And_Build --
--------------------
procedure Copy_And_Build is
- Full_N : Node_Id;
+ Full_Parent : Entity_Id := Parent_Type;
begin
- if Ekind (Parent_Type) in Record_Kind
- or else
- (Ekind (Parent_Type) in Enumeration_Kind
- and then not Is_Standard_Character_Type (Parent_Type)
- 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);
+ -- If the parent is itself derived from another private type,
+ -- installing the private declarations has not affected its
+ -- privacy status, so use its own full view explicitly.
- else
- Build_Derived_Type (
- N, Parent_Type, Full_Der, True, Derive_Subps => False);
+ if Is_Private_Type (Full_Parent)
+ and then Present (Full_View (Full_Parent))
+ then
+ Full_Parent := Full_View (Full_Parent);
end if;
- end Copy_And_Build;
- -- Start of processing for Build_Derived_Private_Type
+ -- And its underlying full view if necessary
- begin
- if Is_Tagged_Type (Parent_Type) then
- Full_P := Full_View (Parent_Type);
+ if Is_Private_Type (Full_Parent)
+ and then Present (Underlying_Full_View (Full_Parent))
+ then
+ Full_Parent := Underlying_Full_View (Full_Parent);
+ end if;
- -- A type extension of a type with unknown discriminants is an
- -- indefinite type that the back-end cannot handle directly.
- -- We treat it as a private type, and build a completion that is
- -- derived from the full view of the parent, and hopefully has
- -- known discriminants.
+ -- For record, access and most enumeration types, derivation from
+ -- the full view requires a fully-fledged declaration. In the other
+ -- cases, just use an itype.
- -- If the full view of the parent type has an underlying record view,
- -- use it to generate the underlying record view of this derived type
- -- (required for chains of derivations with unknown discriminants).
+ if Ekind (Full_Parent) in Record_Kind
+ or else Ekind (Full_Parent) in Access_Kind
+ or else
+ (Ekind (Full_Parent) in Enumeration_Kind
+ and then not Is_Standard_Character_Type (Full_Parent)
+ and then not Is_Generic_Type (Root_Type (Full_Parent)))
+ then
+ -- Copy and adjust declaration to provide a completion for what
+ -- is originally a private declaration. Indicate that full view
+ -- is internally generated.
- -- Minor optimization: we avoid the generation of useless underlying
- -- record view entities if the private type declaration has unknown
- -- discriminants but its corresponding full view has no
- -- discriminants.
+ Set_Comes_From_Source (Full_N, False);
+ Set_Comes_From_Source (Full_Der, False);
+ Set_Parent (Full_Der, Full_N);
+ Set_Defining_Identifier (Full_N, Full_Der);
- if Has_Unknown_Discriminants (Parent_Type)
- and then Present (Full_P)
- and then (Has_Discriminants (Full_P)
- or else Present (Underlying_Record_View (Full_P)))
- and then not In_Open_Scopes (Par_Scope)
- and then Expander_Active
- then
- declare
- Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T');
- New_Ext : constant Node_Id :=
- Copy_Separate_Tree
- (Record_Extension_Part (Type_Definition (N)));
- Decl : Node_Id;
+ -- If there are no constraints, adjust the subtype mark
+
+ if Nkind (Subtype_Indication (Type_Definition (Full_N))) /=
+ N_Subtype_Indication
+ then
+ Set_Subtype_Indication
+ (Type_Definition (Full_N),
+ New_Occurrence_Of (Full_Parent, Sloc (Full_N)));
+ end if;
+
+ Insert_After (N, Full_N);
+
+ -- Build full view of derived type from full view of parent which
+ -- is now installed. Subprograms have been derived on the partial
+ -- view, the completion does not derive them anew.
+
+ if Ekind (Full_Parent) in Record_Kind then
+
+ -- If parent type is tagged, the completion inherits the proper
+ -- primitive operations.
+
+ if Is_Tagged_Type (Parent_Type) then
+ Build_Derived_Record_Type
+ (Full_N, Full_Parent, Full_Der, Derive_Subps);
+ else
+ Build_Derived_Record_Type
+ (Full_N, Full_Parent, Full_Der, Derive_Subps => False);
+ end if;
+
+ else
+ Build_Derived_Type
+ (Full_N, Full_Parent, Full_Der,
+ Is_Completion => False, Derive_Subps => False);
+ end if;
+
+ -- The full declaration has been introduced into the tree and
+ -- processed in the step above. It should not be analyzed again
+ -- (when encountered later in the current list of declarations)
+ -- to prevent spurious name conflicts. The full entity remains
+ -- invisible.
+
+ Set_Analyzed (Full_N);
+
+ else
+ Full_Der :=
+ Make_Defining_Identifier (Sloc (Derived_Type),
+ Chars => Chars (Derived_Type));
+ Set_Is_Itype (Full_Der);
+ Set_Associated_Node_For_Itype (Full_Der, N);
+ Set_Parent (Full_Der, N);
+ Build_Derived_Type
+ (N, Full_Parent, Full_Der,
+ Is_Completion => False, Derive_Subps => False);
+ end if;
+
+ Set_Has_Private_Declaration (Full_Der);
+ Set_Has_Private_Declaration (Derived_Type);
+
+ Set_Scope (Full_Der, Scope (Derived_Type));
+ 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_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_Is_Public (Full_Der, Is_Public (Derived_Type));
+
+ -- The convention on the base type may be set in the private part
+ -- and not propagated to the subtype until later, so we obtain the
+ -- convention from the base type of the parent.
+
+ Set_Convention (Full_Der, Convention (Base_Type (Full_Parent)));
+ end Copy_And_Build;
+
+ -- Start of processing for Build_Derived_Private_Type
+
+ begin
+ if Is_Tagged_Type (Parent_Type) then
+ Full_P := Full_View (Parent_Type);
+
+ -- A type extension of a type with unknown discriminants is an
+ -- indefinite type that the back-end cannot handle directly.
+ -- We treat it as a private type, and build a completion that is
+ -- derived from the full view of the parent, and hopefully has
+ -- known discriminants.
+
+ -- If the full view of the parent type has an underlying record view,
+ -- use it to generate the underlying record view of this derived type
+ -- (required for chains of derivations with unknown discriminants).
+
+ -- Minor optimization: we avoid the generation of useless underlying
+ -- record view entities if the private type declaration has unknown
+ -- discriminants but its corresponding full view has no
+ -- discriminants.
+
+ if Has_Unknown_Discriminants (Parent_Type)
+ and then Present (Full_P)
+ and then (Has_Discriminants (Full_P)
+ or else Present (Underlying_Record_View (Full_P)))
+ and then not In_Open_Scopes (Par_Scope)
+ and then Expander_Active
+ then
+ declare
+ Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T');
+ New_Ext : constant Node_Id :=
+ Copy_Separate_Tree
+ (Record_Extension_Part (Type_Definition (N)));
+ Decl : Node_Id;
begin
Build_Derived_Record_Type
Set_Is_Frozen (Full_Der);
+ -- If the derived type has access discriminants, create
+ -- references to their anonymous types now, to prevent
+ -- back-end problems when their first use is in generated
+ -- bodies of primitives.
+
+ declare
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Full_Der);
+
+ while Present (E) loop
+ if Ekind (E) = E_Discriminant
+ and then Ekind (Etype (E)) = E_Anonymous_Access_Type
+ then
+ Build_Itype_Reference (Etype (E), Decl);
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end;
+
-- Set up links between real entity and underlying record view
Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der));
return;
elsif Has_Discriminants (Parent_Type) then
- if Present (Full_View (Parent_Type)) then
- if not Is_Completion then
- -- Copy declaration for subsequent analysis, to provide a
- -- completion for what is a private declaration. Indicate that
- -- the full type is internally generated.
-
- Full_Decl := New_Copy_Tree (N);
- Full_Der := New_Copy (Derived_Type);
- Set_Comes_From_Source (Full_Decl, False);
- Set_Comes_From_Source (Full_Der, False);
- Set_Parent (Full_Der, Full_Decl);
-
- Insert_After (N, Full_Decl);
-
- else
- -- If this is a completion, the full view being built is itself
- -- private. We build a subtype of the parent with the same
- -- constraints as this full view, to convey to the back end the
- -- constrained components and the size of this subtype. If the
- -- parent is constrained, its full view can serve as the
- -- underlying full view of the derived type.
-
- 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
- -- If there are new discriminants, the parent subtype is
- -- constrained by them, but it is not clear how to build
- -- the Underlying_Full_View in this case???
-
- null;
- end if;
- end if;
- end if;
-
- -- Build partial view of derived type from partial view of parent
+ -- Build partial view of derived type from partial view of parent.
+ -- This must be done before building the full derivation because the
+ -- second derivation will modify the discriminants of the first and
+ -- the discriminants are chained with the rest of the components in
+ -- the full derivation.
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
- -- Swap partial and full views temporarily
-
- Install_Private_Declarations (Par_Scope);
- Install_Visible_Declarations (Par_Scope);
- Swapped := True;
- end if;
+ -- Build the full derivation if this is not the anonymous derived
+ -- base type created by Build_Derived_Record_Type in the constrained
+ -- case (see point 5. of its head comment) since we build it for the
+ -- derived subtype. And skip it for protected types altogether, as
+ -- gigi does not use these types directly.
- -- Build full view of derived type from full view of parent which
- -- is now installed. Subprograms have been derived on the partial
- -- view, the completion does not derive them anew.
+ if Present (Full_View (Parent_Type))
+ and then not Is_Itype (Derived_Type)
+ and then not (Ekind (Full_View (Parent_Type)) in Protected_Kind)
+ then
+ declare
+ Der_Base : constant Entity_Id := Base_Type (Derived_Type);
+ Discr : Entity_Id;
+ Last_Discr : Entity_Id;
- if not Is_Tagged_Type (Parent_Type) then
+ begin
+ -- If this is not a completion, construct the implicit full
+ -- view by deriving from the full view of the parent type.
+ -- But if this is a completion, the derived private type
+ -- being built is a full view and the full derivation can
+ -- only be its underlying full view.
- -- If the parent is itself derived from another private type,
- -- installing the private declarations has not affected its
- -- privacy status, so use its own full view explicitly.
+ Build_Full_Derivation;
- if Is_Private_Type (Parent_Type) then
- Build_Derived_Record_Type
- (Full_Decl, Full_View (Parent_Type), Full_Der, False);
+ if not Is_Completion then
+ Set_Full_View (Derived_Type, Full_Der);
else
- Build_Derived_Record_Type
- (Full_Decl, Parent_Type, Full_Der, False);
+ Set_Underlying_Full_View (Derived_Type, Full_Der);
end if;
- else
- -- If full view of parent is tagged, the completion inherits
- -- the proper primitive operations.
-
- Set_Defining_Identifier (Full_Decl, Full_Der);
- Build_Derived_Record_Type
- (Full_Decl, Parent_Type, Full_Der, Derive_Subps);
- end if;
-
- -- The full declaration has been introduced into the tree and
- -- processed in the step above. It should not be analyzed again
- -- (when encountered later in the current list of declarations)
- -- to prevent spurious name conflicts. The full entity remains
- -- invisible.
-
- Set_Analyzed (Full_Decl);
-
- if Swapped then
- Uninstall_Declarations (Par_Scope);
-
- if In_Open_Scopes (Par_Scope) then
- Install_Visible_Declarations (Par_Scope);
+ if not Is_Base_Type (Derived_Type) then
+ Set_Full_View (Der_Base, Base_Type (Full_Der));
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));
-
- -- Copy the discriminant list from full view to the partial views
- -- (base type and its subtype). Gigi requires that the partial and
- -- full views have the same discriminants.
-
- -- Note that since the partial view is pointing to discriminants
- -- in the full view, their scope will be that of the full view.
- -- This might cause some front end problems and need adjustment???
- Discr := First_Discriminant (Base_Type (Full_Der));
- Set_First_Entity (Der_Base, Discr);
+ -- Copy the discriminant list from full view to the partial
+ -- view (base type and its subtype). Gigi requires that the
+ -- partial and full views have the same discriminants.
- loop
- Last_Discr := Discr;
- Next_Discriminant (Discr);
- exit when No (Discr);
- end loop;
+ -- Note that since the partial view points to discriminants
+ -- in the full view, their scope will be that of the full
+ -- view. This might cause some front end problems and need
+ -- adjustment???
- Set_Last_Entity (Der_Base, Last_Discr);
+ Discr := First_Discriminant (Base_Type (Full_Der));
+ Set_First_Entity (Der_Base, Discr);
- Set_First_Entity (Derived_Type, First_Entity (Der_Base));
- Set_Last_Entity (Derived_Type, Last_Entity (Der_Base));
- Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type));
+ loop
+ Last_Discr := Discr;
+ Next_Discriminant (Discr);
+ exit when No (Discr);
+ end loop;
- else
- -- If this is a completion, the derived type stays private and
- -- there is no need to create a further full view, except in the
- -- unusual case when the derivation is nested within a child unit,
- -- see below.
+ 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));
- null;
+ Set_Stored_Constraint
+ (Full_Der, Stored_Constraint (Derived_Type));
+ end;
end if;
elsif Present (Full_View (Parent_Type))
- and then Has_Discriminants (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))) =
return;
end if;
- -- 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. For code generation and linking, the full view must have
- -- the same public status as the partial one. This full view is only
- -- needed if the parent type is in an enclosing scope, so that the
- -- full view may actually become visible, e.g. in a child unit. This
- -- is both more efficient, and avoids order of freezing problems with
- -- the added entities.
+ -- If this is not a completion, construct the implicit full view by
+ -- deriving from the full view of the parent type. But if this is a
+ -- completion, the derived private type being built is a full view
+ -- and the full derivation can only be its underlying full view.
- if not Is_Private_Type (Full_View (Parent_Type))
- and then (In_Open_Scopes (Scope (Parent_Type)))
- then
- Full_Der :=
- Make_Defining_Identifier (Sloc (Derived_Type),
- Chars => Chars (Derived_Type));
+ Build_Full_Derivation;
- 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));
+ if not Is_Completion then
Set_Full_View (Derived_Type, Full_Der);
- Set_Is_Public (Full_Der, Is_Public (Derived_Type));
- 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);
-
- -- Except in the context of the full view of the parent, there
- -- are no non-extension aggregates for the derived type.
-
- Set_Has_Private_Ancestor (Derived_Type);
+ Set_Underlying_Full_View (Derived_Type, Full_Der);
end if;
-- In any case, the primitive operations are inherited from the
Derive_Subprograms (Parent_Type, Derived_Type);
end if;
+ Set_Stored_Constraint (Derived_Type, No_Elist);
+ Set_Is_Constrained
+ (Derived_Type, Is_Constrained (Full_View (Parent_Type)));
+
else
-- Untagged type, No discriminants on either view
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
end if;
- -- Construct the implicit full view by deriving from full view of the
- -- parent type. In order to get proper visibility, we install the
- -- parent scope and its declarations.
+ -- If this is not a completion, construct the implicit full view by
+ -- deriving from the full view of the parent type.
-- ??? If the parent is untagged private and its completion is
-- tagged, this mechanism will not work because we cannot derive from
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));
+ Build_Full_Derivation;
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);
-
- -- If parent scope is open and in another unit, and parent has a
- -- completion, then the derivation is taking place in the visible
- -- part of a child unit. In that case retrieve the full view of
- -- the parent momentarily.
-
- 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);
-
- -- Otherwise it is a local derivation
-
- 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_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
+ -- If the parent base type is in scope, add the derived type to its
+ -- list of private dependents, because its full view may become
+ -- visible subsequently (in a nested private part, a body, or in a
+ -- further child unit).
+
+ if Is_Private_Type (Par_Base) and then In_Open_Scopes (Par_Scope) then
Append_Elmt (Derived_Type, Private_Dependents (Parent_Type));
-- Check for unusual case where a type completed by a private
then
-- In this case, the full view of the parent type will become
-- visible in the body of the enclosing child, and only then will
- -- the current type be possibly non-private. We build an
- -- underlying full view that will be installed when the enclosing
- -- child body is compiled.
+ -- the current type be possibly non-private. Build an underlying
+ -- full view that will be installed when the enclosing child body
+ -- is compiled.
- Full_Der :=
- Make_Defining_Identifier
- (Sloc (Derived_Type), Chars (Derived_Type));
- Set_Is_Itype (Full_Der);
- Build_Itype_Reference (Full_Der, N);
+ if Present (Underlying_Full_View (Derived_Type)) then
+ Full_Der := Underlying_Full_View (Derived_Type);
+ else
+ Build_Full_Derivation;
+ Set_Underlying_Full_View (Derived_Type, Full_Der);
+ end if;
-- The full view will be used to swap entities on entry/exit to
-- the body, and must appear in the entity list for the package.
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 if;
end if;
end Build_Derived_Private_Type;
if not Has_Discriminants (Parent_Base)
or else
(Has_Unknown_Discriminants (Parent_Base)
- and then Is_Private_Type (Parent_Base))
+ and then Is_Private_Type (Parent_Base))
then
Error_Msg_N
("invalid constraint: type has no discriminant",
Build_Derived_Type
(New_Decl, Parent_Base, New_Base,
- Is_Completion => True, Derive_Subps => False);
+ Is_Completion => False, Derive_Subps => False);
-- ??? This needs re-examination to determine whether the
-- above call can simply be replaced by a call to Analyze.
while Present (C) loop
Expr := Node (C);
- -- It is safe here to call New_Copy_Tree since
- -- Force_Evaluation was called on each constraint in
- -- Build_Discriminant_Constraints.
+ -- It is safe here to call New_Copy_Tree since we called
+ -- Force_Evaluation on each constraint previously
+ -- in Build_Discriminant_Constraints.
Append (New_Copy_Tree (Expr), To => Constr_List);
elsif Is_Limited_Record (Parent_Type)
or else (Present (Full_View (Parent_Type))
- and then Is_Limited_Record (Full_View (Parent_Type)))
+ and then Is_Limited_Record (Full_View (Parent_Type)))
then
if not Is_Interface (Parent_Type)
or else Is_Synchronized_Interface (Parent_Type)
declare
Corr_Disc : constant Entity_Id :=
- Corresponding_Discriminant (Discrim);
+ Corresponding_Discriminant (Discrim);
Disc_Type : constant Entity_Id := Etype (Discrim);
Corr_Type : Entity_Id;
Set_Is_Constrained
(Derived_Type,
not (Inherit_Discrims
- or else Has_Unknown_Discriminants (Derived_Type)));
+ or else Has_Unknown_Discriminants (Derived_Type)));
end if;
-- STEP 3: initialize fields of derived type
-- Fields inherited from the Parent_Type
Set_Has_Specified_Layout
- (Derived_Type, Has_Specified_Layout (Parent_Type));
+ (Derived_Type, Has_Specified_Layout (Parent_Type));
Set_Is_Limited_Composite
- (Derived_Type, Is_Limited_Composite (Parent_Type));
+ (Derived_Type, Is_Limited_Composite (Parent_Type));
Set_Is_Private_Composite
- (Derived_Type, Is_Private_Composite (Parent_Type));
+ (Derived_Type, Is_Private_Composite (Parent_Type));
+
+ if Is_Tagged_Type (Parent_Type) then
+ Set_No_Tagged_Streams_Pragma
+ (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type));
+ end if;
-- Fields inherited from the Parent_Base
-- Fields inherited from the Parent_Base for record types
if Is_Record_Type (Derived_Type) then
-
declare
Parent_Full : Entity_Id;
if Is_Itype (Derived_Type) then
declare
Def : constant Node_Id :=
- Associated_Node_For_Itype (Derived_Type);
+ Associated_Node_For_Itype (Derived_Type);
begin
if Present (Def)
and then Nkind (Def) = N_Full_Type_Declaration
end if;
end;
end if;
+
+ -- Propagate inherited invariant information of parents
+ -- and progenitors
+
+ if Ada_Version >= Ada_2012
+ and then not Is_Interface (Derived_Type)
+ then
+ if Has_Inheritable_Invariants (Parent_Type) then
+ Set_Has_Invariants (Derived_Type);
+ Set_Has_Inheritable_Invariants (Derived_Type);
+
+ elsif not Is_Empty_Elmt_List (Ifaces_List) then
+ declare
+ AI : Elmt_Id;
+
+ begin
+ AI := First_Elmt (Ifaces_List);
+ while Present (AI) loop
+ if Has_Inheritable_Invariants (Node (AI)) then
+ Set_Has_Invariants (Derived_Type);
+ Set_Has_Inheritable_Invariants (Derived_Type);
+
+ exit;
+ end if;
+
+ Next_Elmt (AI);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ -- A type extension is automatically Ghost when one of its
+ -- progenitors is Ghost (SPARK RM 6.9(9)). This property is
+ -- also inherited when the parent type is Ghost, but this is
+ -- done in Build_Derived_Type as the mechanism also handles
+ -- untagged derivations.
+
+ if Implements_Ghost_Interface (Derived_Type) then
+ Set_Is_Ghost_Entity (Derived_Type);
+ end if;
end;
end if;
-- STEP 5c: Process the record extension for non private tagged types
elsif not Private_Extension then
+ Expand_Record_Extension (Derived_Type, Type_Def);
- -- Add the _parent field in the derived type. In ASIS mode there is
- -- not enough semantic information for full expansion, but set the
- -- parent subtype to allow resolution of selected components in
- -- instance bodies.
-
- if ASIS_Mode then
- Set_Parent_Subtype (Derived_Type, Parent_Type);
- else
- Expand_Record_Extension (Derived_Type, Type_Def);
- end if;
+ -- Note : previously in ASIS mode we set the Parent_Subtype of the
+ -- derived type to propagate some semantic information. This led
+ -- to other ASIS failures and has been removed.
-- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
-- implemented interfaces if we are in expansion mode
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
+ Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
+
+ if Is_Tagged_Type (Derived_Type) then
+ Set_No_Tagged_Streams_Pragma
+ (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type));
+ end if;
-- If the parent has primitive routines, set the derived type link
-- type may be set in the private part, and not propagated to the
-- subtype until later, so we obtain the convention from the base type.
- Set_Convention (Derived_Type, Convention (Parent_Base));
+ Set_Convention (Derived_Type, Convention (Parent_Base));
-- Set SSO default for record or array type
- if (Is_Array_Type (Derived_Type)
- or else Is_Record_Type (Derived_Type))
+ if (Is_Array_Type (Derived_Type) or else Is_Record_Type (Derived_Type))
and then Is_Base_Type (Derived_Type)
then
Set_Default_SSO (Derived_Type);
Set_Has_Predicates (Derived_Type);
end if;
- -- The derived type inherits the representation clauses of the parent.
- -- However, for a private type that is completed by a derivation, there
- -- may be operation attributes that have been specified already (stream
- -- attributes and External_Tag) and those must be provided. Finally,
- -- if the partial view is a private extension, the representation items
- -- of the parent have been inherited already, and should not be chained
- -- twice to the derived type.
-
- if Is_Tagged_Type (Parent_Type)
- and then Present (First_Rep_Item (Derived_Type))
- then
- -- The existing items are either operational items or items inherited
- -- from a private extension declaration.
-
- declare
- Rep : Node_Id;
- -- Used to iterate over representation items of the derived type
-
- Last_Rep : Node_Id;
- -- Last representation item of the (non-empty) representation
- -- item list of the derived type.
-
- Found : Boolean := False;
-
- begin
- Rep := First_Rep_Item (Derived_Type);
- Last_Rep := Rep;
- while Present (Rep) loop
- if Rep = First_Rep_Item (Parent_Type) then
- Found := True;
- exit;
-
- else
- Rep := Next_Rep_Item (Rep);
-
- if Present (Rep) then
- Last_Rep := Rep;
- end if;
- end if;
- end loop;
+ -- The derived type inherits the representation clauses of the parent
- -- Here if we either encountered the parent type's first rep
- -- item on the derived type's rep item list (in which case
- -- Found is True, and we have nothing else to do), or if we
- -- reached the last rep item of the derived type, which is
- -- Last_Rep, in which case we further chain the parent type's
- -- rep items to those of the derived type.
+ Inherit_Rep_Item_Chain (Derived_Type, Parent_Type);
- if not Found then
- Set_Next_Rep_Item (Last_Rep, First_Rep_Item (Parent_Type));
- end if;
- end;
+ -- Propagate the attributes related to pragma Default_Initial_Condition
+ -- from the parent type to the private extension. A derived type always
+ -- inherits the default initial condition flag from the parent type. If
+ -- the derived type carries its own Default_Initial_Condition pragma,
+ -- the flag is later reset in Analyze_Pragma. Note that both flags are
+ -- mutually exclusive.
- else
- Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
- end if;
+ Propagate_Default_Init_Cond_Attributes
+ (From_Typ => Parent_Type,
+ To_Typ => Derived_Type,
+ Parent_To_Derivation => True);
-- If the parent type has delayed rep aspects, then mark the derived
-- type as possibly inheriting a delayed rep aspect.
Set_May_Inherit_Delayed_Rep_Aspects (Derived_Type);
end if;
+ -- Propagate the attributes related to pragma Ghost from the parent type
+ -- to the derived type or type extension (SPARK RM 6.9(9)).
+
+ if Is_Ghost_Entity (Parent_Type) then
+ Set_Is_Ghost_Entity (Derived_Type);
+ end if;
+
-- Type dependent processing
case Ekind (Parent_Type) is
-- and in family bounds.
if Is_Concurrent_Type (Current_Scope)
- or else Is_Limited_Type (Current_Scope)
+ or else
+ Is_Limited_Type (Current_Scope)
then
CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
elsif Nkind (Constr) = N_Range
or else (Nkind (Constr) = N_Attribute_Reference
- and then
- Attribute_Name (Constr) = Name_Range)
+ and then Attribute_Name (Constr) = Name_Range)
then
Error_Msg_N
("a range is not a valid discriminant constraint", Constr);
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Def_Id);
+ Set_No_Tagged_Streams_Pragma (Def_Id, No_Tagged_Streams_Pragma (T));
Make_Class_Wide_Type (Def_Id);
end if;
then
null;
+ -- A null extension is not obliged to override an inherited
+ -- procedure subject to pragma Extensions_Visible with value
+ -- False and at least one controlling OUT parameter
+ -- (SPARK RM 6.1.7(6)).
+
+ elsif Is_Null_Extension (T)
+ and then Is_EVF_Procedure (Subp)
+ then
+ null;
+
else
Error_Msg_NE
("type must be declared abstract or & overridden",
("\& subprogram# is not visible",
T, Subp);
+ -- Clarify the case where a non-null extension must
+ -- override inherited procedure subject to pragma
+ -- Extensions_Visible with value False and at least
+ -- one controlling OUT param.
+
+ elsif Is_EVF_Procedure (E) then
+ Error_Msg_NE
+ ("\& # is subject to Extensions_Visible False",
+ T, Subp);
+
else
Error_Msg_NE
("\& has been inherited from subprogram #",
elsif Is_Concurrent_Record_Type (T)
and then Present (Interfaces (T))
then
- -- If an inherited subprogram is implemented by a protected
- -- procedure or an entry, then the first parameter of the
- -- inherited subprogram shall be of mode OUT or IN OUT, or
- -- an access-to-variable parameter (RM 9.4(11.9/3))
-
- if Is_Protected_Type (Corresponding_Concurrent_Type (T))
- and then Ekind (First_Formal (Subp)) = E_In_Parameter
- and then Ekind (Subp) /= E_Function
- and then not Is_Predefined_Dispatching_Operation (Subp)
- then
- Error_Msg_PT (T, Subp);
-
- -- Some other kind of overriding failure
+ -- There is no need to check here RM 9.4(11.9/3) since we
+ -- are processing the corresponding record type and the
+ -- mode of the overriding subprograms was verified by
+ -- Check_Conformance when the corresponding concurrent
+ -- type declaration was analyzed.
- else
- Error_Msg_NE
- ("interface subprogram & must be overridden",
- T, Subp);
+ Error_Msg_NE
+ ("interface subprogram & must be overridden", T, Subp);
- -- Examine primitive operations of synchronized type,
- -- to find homonyms that have the wrong profile.
+ -- Examine primitive operations of synchronized type to find
+ -- homonyms that have the wrong profile.
- declare
- Prim : Entity_Id;
+ declare
+ Prim : Entity_Id;
- begin
- Prim :=
- First_Entity (Corresponding_Concurrent_Type (T));
- while Present (Prim) loop
- if Chars (Prim) = Chars (Subp) then
- Error_Msg_NE
- ("profile is not type conformant with "
- & "prefixed view profile of "
- & "inherited operation&", Prim, Subp);
- end if;
+ begin
+ Prim := First_Entity (Corresponding_Concurrent_Type (T));
+ while Present (Prim) loop
+ if Chars (Prim) = Chars (Subp) then
+ Error_Msg_NE
+ ("profile is not type conformant with prefixed "
+ & "view profile of inherited operation&",
+ Prim, Subp);
+ end if;
- Next_Entity (Prim);
- end loop;
- end;
- end if;
+ Next_Entity (Prim);
+ end loop;
+ end;
end if;
else
Error_Msg_Node_2 := Subp;
Error_Msg_N ("nonabstract type& has abstract subprogram&!", T);
end if;
+
+ -- A subprogram subject to pragma Extensions_Visible with value
+ -- "True" cannot override a subprogram subject to the same pragma
+ -- with value "False" (SPARK RM 6.1.7(5)).
+
+ elsif Extensions_Visible_Status (Subp) = Extensions_Visible_True
+ and then Present (Overridden_Operation (Subp))
+ and then Extensions_Visible_Status (Overridden_Operation (Subp)) =
+ Extensions_Visible_False
+ then
+ Error_Msg_Sloc := Sloc (Overridden_Operation (Subp));
+ Error_Msg_N
+ ("subprogram & with Extensions_Visible True cannot override "
+ & "subprogram # with Extensions_Visible False", Subp);
end if;
-- Ada 2012 (AI05-0030): Perform checks related to pragma Implemented
end if;
end Check_Aliased_Component_Types;
- ----------------------
- -- Check_Completion --
- ----------------------
+ ---------------------------------------
+ -- Check_Anonymous_Access_Components --
+ ---------------------------------------
- procedure Check_Completion (Body_Id : Node_Id := Empty) is
- E : Entity_Id;
+ procedure Check_Anonymous_Access_Components
+ (Typ_Decl : Node_Id;
+ Typ : Entity_Id;
+ Prev : Entity_Id;
+ Comp_List : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Typ_Decl);
+ Anon_Access : Entity_Id;
+ Acc_Def : Node_Id;
+ Comp : Node_Id;
+ Comp_Def : Node_Id;
+ Decl : Node_Id;
+ Type_Def : Node_Id;
- procedure Post_Error;
- -- Post error message for lack of completion for entity E
+ procedure Build_Incomplete_Type_Declaration;
+ -- If the record type contains components that include an access to the
+ -- current record, then create an incomplete type declaration for the
+ -- record, to be used as the designated type of the anonymous access.
+ -- This is done only once, and only if there is no previous partial
+ -- view of the type.
- ----------------
- -- Post_Error --
- ----------------
+ function Designates_T (Subt : Node_Id) return Boolean;
+ -- Check whether a node designates the enclosing record type, or 'Class
+ -- of that type
- procedure Post_Error is
+ function Mentions_T (Acc_Def : Node_Id) return Boolean;
+ -- Check whether an access definition includes a reference to
+ -- the enclosing record type. The reference can be a subtype mark
+ -- in the access definition itself, a 'Class attribute reference, or
+ -- recursively a reference appearing in a parameter specification
+ -- or result definition of an access_to_subprogram definition.
- procedure Missing_Body;
- -- Output missing body message
+ --------------------------------------
+ -- Build_Incomplete_Type_Declaration --
+ --------------------------------------
- ------------------
- -- Missing_Body --
- ------------------
+ procedure Build_Incomplete_Type_Declaration is
+ Decl : Node_Id;
+ Inc_T : Entity_Id;
+ H : Entity_Id;
- procedure Missing_Body is
- begin
- -- Spec is in same unit, so we can post on spec
+ -- Is_Tagged indicates whether the type is tagged. It is tagged if
+ -- it's "is new ... with record" or else "is tagged record ...".
- if In_Same_Source_Unit (Body_Id, E) then
- Error_Msg_N ("missing body for &", E);
+ Is_Tagged : constant Boolean :=
+ (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
+ and then
+ Present (Record_Extension_Part (Type_Definition (Typ_Decl))))
+ or else
+ (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition
+ and then Tagged_Present (Type_Definition (Typ_Decl)));
- -- Spec is in a separate unit, so we have to post on the body
+ begin
+ -- If there is a previous partial view, no need to create a new one
+ -- If the partial view, given by Prev, is incomplete, If Prev is
+ -- a private declaration, full declaration is flagged accordingly.
- else
- Error_Msg_NE ("missing body for & declared#!", Body_Id, E);
+ if Prev /= Typ then
+ if Is_Tagged then
+ Make_Class_Wide_Type (Prev);
+ Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev));
+ Set_Etype (Class_Wide_Type (Typ), Typ);
end if;
- end Missing_Body;
- -- Start of processing for Post_Error
+ return;
- begin
- if not Comes_From_Source (E) then
+ elsif Has_Private_Declaration (Typ) then
- if Ekind_In (E, E_Task_Type, E_Protected_Type) then
- -- It may be an anonymous protected type created for a
- -- single variable. Post error on variable, if present.
+ -- If we refer to T'Class inside T, and T is the completion of a
+ -- private type, then make sure the class-wide type exists.
- declare
- Var : Entity_Id;
+ if Is_Tagged then
+ Make_Class_Wide_Type (Typ);
+ end if;
- begin
- Var := First_Entity (Current_Scope);
- while Present (Var) loop
- exit when Etype (Var) = E
- and then Comes_From_Source (Var);
+ return;
- Next_Entity (Var);
- end loop;
+ -- If there was a previous anonymous access type, the incomplete
+ -- type declaration will have been created already.
- if Present (Var) then
- E := Var;
- end if;
- end;
+ elsif Present (Current_Entity (Typ))
+ and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
+ and then Full_View (Current_Entity (Typ)) = Typ
+ then
+ if Is_Tagged
+ and then Comes_From_Source (Current_Entity (Typ))
+ and then not Is_Tagged_Type (Current_Entity (Typ))
+ then
+ Make_Class_Wide_Type (Typ);
+ Error_Msg_N
+ ("incomplete view of tagged type should be declared tagged??",
+ Parent (Current_Entity (Typ)));
end if;
- end if;
-
- -- If a generated entity has no completion, then either previous
- -- semantic errors have disabled the expansion phase, or else we had
- -- missing subunits, or else we are compiling without expansion,
- -- or else something is very wrong.
-
- if not Comes_From_Source (E) then
- pragma Assert
- (Serious_Errors_Detected > 0
- or else Configurable_Run_Time_Violations > 0
- or else Subunits_Missing
- or else not Expander_Active);
return;
- -- Here for source entity
-
else
- -- Here if no body to post the error message, so we post the error
- -- on the declaration that has no completion. This is not really
- -- the right place to post it, think about this later ???
+ Inc_T := Make_Defining_Identifier (Loc, Chars (Typ));
+ Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T);
- if No (Body_Id) then
- if Is_Type (E) then
- Error_Msg_NE
- ("missing full declaration for }", Parent (E), E);
- else
- Error_Msg_NE ("missing body for &", Parent (E), E);
- end if;
+ -- Type has already been inserted into the current scope. Remove
+ -- it, and add incomplete declaration for type, so that subsequent
+ -- anonymous access types can use it. The entity is unchained from
+ -- the homonym list and from immediate visibility. After analysis,
+ -- the entity in the incomplete declaration becomes immediately
+ -- visible in the record declaration that follows.
- -- Package body has no completion for a declaration that appears
- -- in the corresponding spec. Post error on the body, with a
- -- reference to the non-completed declaration.
+ H := Current_Entity (Typ);
+ if H = Typ then
+ Set_Name_Entity_Id (Chars (Typ), Homonym (Typ));
else
- Error_Msg_Sloc := Sloc (E);
-
- if Is_Type (E) then
- Error_Msg_NE ("missing full declaration for }!", Body_Id, E);
+ while Present (H)
+ and then Homonym (H) /= Typ
+ loop
+ H := Homonym (Typ);
+ end loop;
- elsif Is_Overloadable (E)
- and then Current_Entity_In_Scope (E) /= E
- then
- -- It may be that the completion is mistyped and appears as
- -- a distinct overloading of the entity.
+ Set_Homonym (H, Homonym (Typ));
+ end if;
- declare
- Candidate : constant Entity_Id :=
- Current_Entity_In_Scope (E);
- Decl : constant Node_Id :=
- Unit_Declaration_Node (Candidate);
+ Insert_Before (Typ_Decl, Decl);
+ Analyze (Decl);
+ Set_Full_View (Inc_T, Typ);
- begin
- if Is_Overloadable (Candidate)
- and then Ekind (Candidate) = Ekind (E)
- and then Nkind (Decl) = N_Subprogram_Body
- and then Acts_As_Spec (Decl)
- then
- Check_Type_Conformant (Candidate, E);
+ if Is_Tagged then
- else
- Missing_Body;
- end if;
- end;
+ -- Create a common class-wide type for both views, and set the
+ -- Etype of the class-wide type to the full view.
- else
- Missing_Body;
- end if;
+ Make_Class_Wide_Type (Inc_T);
+ Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T));
+ Set_Etype (Class_Wide_Type (Typ), Typ);
end if;
end if;
- end Post_Error;
-
- -- Start of processing for Check_Completion
+ end Build_Incomplete_Type_Declaration;
- begin
- E := First_Entity (Current_Scope);
- while Present (E) loop
- if Is_Intrinsic_Subprogram (E) then
- null;
+ ------------------
+ -- Designates_T --
+ ------------------
- -- The following situation requires special handling: a child unit
- -- that appears in the context clause of the body of its parent:
+ function Designates_T (Subt : Node_Id) return Boolean is
+ Type_Id : constant Name_Id := Chars (Typ);
- -- procedure Parent.Child (...);
+ function Names_T (Nam : Node_Id) return Boolean;
+ -- The record type has not been introduced in the current scope
+ -- yet, so we must examine the name of the type itself, either
+ -- an identifier T, or an expanded name of the form P.T, where
+ -- P denotes the current scope.
- -- with Parent.Child;
- -- package body Parent is
+ -------------
+ -- Names_T --
+ -------------
- -- Here Parent.Child appears as a local entity, but should not be
- -- flagged as requiring completion, because it is a compilation
- -- unit.
+ function Names_T (Nam : Node_Id) return Boolean is
+ begin
+ if Nkind (Nam) = N_Identifier then
+ return Chars (Nam) = Type_Id;
- -- Ignore missing completion for a subprogram that does not come from
- -- source (including the _Call primitive operation of RAS types,
- -- which has to have the flag Comes_From_Source for other purposes):
- -- we assume that the expander will provide the missing completion.
- -- In case of previous errors, other expansion actions that provide
- -- bodies for null procedures with not be invoked, so inhibit message
- -- in those cases.
+ elsif Nkind (Nam) = N_Selected_Component then
+ if Chars (Selector_Name (Nam)) = Type_Id then
+ if Nkind (Prefix (Nam)) = N_Identifier then
+ return Chars (Prefix (Nam)) = Chars (Current_Scope);
- -- Note that E_Operator is not in the list that follows, because
- -- this kind is reserved for predefined operators, that are
- -- intrinsic and do not need completion.
-
- elsif Ekind (E) = E_Function
- or else Ekind (E) = E_Procedure
- or else Ekind (E) = E_Generic_Function
- or else Ekind (E) = E_Generic_Procedure
- then
- if Has_Completion (E) then
- null;
-
- elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
- null;
-
- elsif Is_Subprogram (E)
- and then (not Comes_From_Source (E)
- or else Chars (E) = Name_uCall)
- then
- null;
-
- elsif
- Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
- then
- null;
-
- elsif Nkind (Parent (E)) = N_Procedure_Specification
- and then Null_Present (Parent (E))
- and then Serious_Errors_Detected > 0
- then
- null;
-
- else
- Post_Error;
- end if;
-
- elsif Is_Entry (E) then
- if not Has_Completion (E) and then
- (Ekind (Scope (E)) = E_Protected_Object
- or else Ekind (Scope (E)) = E_Protected_Type)
- then
- Post_Error;
- end if;
+ elsif Nkind (Prefix (Nam)) = N_Selected_Component then
+ return Chars (Selector_Name (Prefix (Nam))) =
+ Chars (Current_Scope);
+ else
+ return False;
+ end if;
- elsif Is_Package_Or_Generic_Package (E) then
- if Unit_Requires_Body (E) then
- if not Has_Completion (E)
- and then Nkind (Parent (Unit_Declaration_Node (E))) /=
- N_Compilation_Unit
- then
- Post_Error;
+ else
+ return False;
end if;
- elsif not Is_Child_Unit (E) then
- May_Need_Implicit_Body (E);
+ else
+ return False;
end if;
+ end Names_T;
- -- A formal incomplete type (Ada 2012) does not require a completion;
- -- other incomplete type declarations do.
-
- elsif Ekind (E) = E_Incomplete_Type
- and then No (Underlying_Type (E))
- and then not Is_Generic_Type (E)
- then
- Post_Error;
+ -- Start of processing for Designates_T
- elsif (Ekind (E) = E_Task_Type or else
- Ekind (E) = E_Protected_Type)
- and then not Has_Completion (E)
- then
- Post_Error;
+ begin
+ if Nkind (Subt) = N_Identifier then
+ return Chars (Subt) = Type_Id;
- -- A single task declared in the current scope is a constant, verify
- -- that the body of its anonymous type is in the same scope. If the
- -- task is defined elsewhere, this may be a renaming declaration for
- -- which no completion is needed.
+ -- Reference can be through an expanded name which has not been
+ -- analyzed yet, and which designates enclosing scopes.
- elsif Ekind (E) = E_Constant
- and then Ekind (Etype (E)) = E_Task_Type
- and then not Has_Completion (Etype (E))
- and then Scope (Etype (E)) = Current_Scope
- then
- Post_Error;
+ elsif Nkind (Subt) = N_Selected_Component then
+ if Names_T (Subt) then
+ return True;
- elsif Ekind (E) = E_Protected_Object
- and then not Has_Completion (Etype (E))
- then
- Post_Error;
+ -- Otherwise it must denote an entity that is already visible.
+ -- The access definition may name a subtype of the enclosing
+ -- type, if there is a previous incomplete declaration for it.
- elsif Ekind (E) = E_Record_Type then
- if Is_Tagged_Type (E) then
- Check_Abstract_Overriding (E);
- Check_Conventions (E);
+ else
+ Find_Selected_Component (Subt);
+ return
+ Is_Entity_Name (Subt)
+ and then Scope (Entity (Subt)) = Current_Scope
+ and then
+ (Chars (Base_Type (Entity (Subt))) = Type_Id
+ or else
+ (Is_Class_Wide_Type (Entity (Subt))
+ and then
+ Chars (Etype (Base_Type (Entity (Subt)))) =
+ Type_Id));
end if;
- Check_Aliased_Component_Types (E);
+ -- A reference to the current type may appear as the prefix of
+ -- a 'Class attribute.
- elsif Ekind (E) = E_Array_Type then
- Check_Aliased_Component_Types (E);
+ elsif Nkind (Subt) = N_Attribute_Reference
+ and then Attribute_Name (Subt) = Name_Class
+ then
+ return Names_T (Prefix (Subt));
+ else
+ return False;
end if;
+ end Designates_T;
- Next_Entity (E);
- end loop;
- end Check_Completion;
+ ----------------
+ -- Mentions_T --
+ ----------------
- ------------------------------------
- -- Check_CPP_Type_Has_No_Defaults --
- ------------------------------------
+ function Mentions_T (Acc_Def : Node_Id) return Boolean is
+ Param_Spec : Node_Id;
- procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is
- Tdef : constant Node_Id := Type_Definition (Declaration_Node (T));
- Clist : Node_Id;
- Comp : Node_Id;
+ Acc_Subprg : constant Node_Id :=
+ Access_To_Subprogram_Definition (Acc_Def);
- begin
- -- Obtain the component list
+ begin
+ if No (Acc_Subprg) then
+ return Designates_T (Subtype_Mark (Acc_Def));
+ end if;
- if Nkind (Tdef) = N_Record_Definition then
- Clist := Component_List (Tdef);
- else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
- Clist := Component_List (Record_Extension_Part (Tdef));
- end if;
+ -- Component is an access_to_subprogram: examine its formals,
+ -- and result definition in the case of an access_to_function.
- -- Check all components to ensure no default expressions
+ Param_Spec := First (Parameter_Specifications (Acc_Subprg));
+ while Present (Param_Spec) loop
+ if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition
+ and then Mentions_T (Parameter_Type (Param_Spec))
+ then
+ return True;
- if Present (Clist) then
- Comp := First (Component_Items (Clist));
- while Present (Comp) loop
- if Present (Expression (Comp)) then
- Error_Msg_N
- ("component of imported 'C'P'P type cannot have "
- & "default expression", Expression (Comp));
+ elsif Designates_T (Parameter_Type (Param_Spec)) then
+ return True;
end if;
- Next (Comp);
+ Next (Param_Spec);
end loop;
- end if;
- end Check_CPP_Type_Has_No_Defaults;
-
- ----------------------------
- -- Check_Delta_Expression --
- ----------------------------
- procedure Check_Delta_Expression (E : Node_Id) is
- begin
- if not (Is_Real_Type (Etype (E))) then
- Wrong_Type (E, Any_Real);
+ if Nkind (Acc_Subprg) = N_Access_Function_Definition then
+ if Nkind (Result_Definition (Acc_Subprg)) =
+ N_Access_Definition
+ then
+ return Mentions_T (Result_Definition (Acc_Subprg));
+ else
+ return Designates_T (Result_Definition (Acc_Subprg));
+ end if;
+ end if;
- elsif not Is_OK_Static_Expression (E) then
- Flag_Non_Static_Expr
- ("non-static expression used for delta value!", E);
+ return False;
+ end Mentions_T;
- elsif not UR_Is_Positive (Expr_Value_R (E)) then
- Error_Msg_N ("delta expression must be positive", E);
+ -- Start of processing for Check_Anonymous_Access_Components
- else
+ begin
+ if No (Comp_List) then
return;
end if;
- -- If any of above errors occurred, then replace the incorrect
- -- expression by the real 0.1, which should prevent further errors.
+ Comp := First (Component_Items (Comp_List));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Declaration
+ and then Present
+ (Access_Definition (Component_Definition (Comp)))
+ and then
+ Mentions_T (Access_Definition (Component_Definition (Comp)))
+ then
+ Comp_Def := Component_Definition (Comp);
+ Acc_Def :=
+ Access_To_Subprogram_Definition (Access_Definition (Comp_Def));
- Rewrite (E,
- Make_Real_Literal (Sloc (E), Ureal_Tenth));
- Analyze_And_Resolve (E, Standard_Float);
- end Check_Delta_Expression;
+ Build_Incomplete_Type_Declaration;
+ Anon_Access := Make_Temporary (Loc, 'S');
- -----------------------------
- -- Check_Digits_Expression --
- -----------------------------
+ -- Create a declaration for the anonymous access type: either
+ -- an access_to_object or an access_to_subprogram.
- procedure Check_Digits_Expression (E : Node_Id) is
- begin
- if not (Is_Integer_Type (Etype (E))) then
- Wrong_Type (E, Any_Integer);
+ if Present (Acc_Def) then
+ if Nkind (Acc_Def) = N_Access_Function_Definition then
+ Type_Def :=
+ Make_Access_Function_Definition (Loc,
+ Parameter_Specifications =>
+ Parameter_Specifications (Acc_Def),
+ Result_Definition => Result_Definition (Acc_Def));
+ else
+ Type_Def :=
+ Make_Access_Procedure_Definition (Loc,
+ Parameter_Specifications =>
+ Parameter_Specifications (Acc_Def));
+ end if;
- elsif not Is_OK_Static_Expression (E) then
- Flag_Non_Static_Expr
- ("non-static expression used for digits value!", E);
+ else
+ Type_Def :=
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ Relocate_Node
+ (Subtype_Mark (Access_Definition (Comp_Def))));
- elsif Expr_Value (E) <= 0 then
- Error_Msg_N ("digits value must be greater than zero", E);
+ Set_Constant_Present
+ (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
+ Set_All_Present
+ (Type_Def, All_Present (Access_Definition (Comp_Def)));
+ end if;
- else
- return;
- end if;
+ Set_Null_Exclusion_Present
+ (Type_Def,
+ Null_Exclusion_Present (Access_Definition (Comp_Def)));
- -- If any of above errors occurred, then replace the incorrect
- -- expression by the integer 1, which should prevent further errors.
+ Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Anon_Access,
+ Type_Definition => Type_Def);
- Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
- Analyze_And_Resolve (E, Standard_Integer);
+ Insert_Before (Typ_Decl, Decl);
+ Analyze (Decl);
- end Check_Digits_Expression;
+ -- If an access to subprogram, create the extra formals
- --------------------------
- -- Check_Initialization --
- --------------------------
+ if Present (Acc_Def) then
+ Create_Extra_Formals (Designated_Type (Anon_Access));
- procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
- begin
- if Is_Limited_Type (T)
- and then not In_Instance
- and then not In_Inlined_Body
- then
- if not OK_For_Limited_Init (T, Exp) then
+ -- If an access to object, preserve entity of designated type,
+ -- for ASIS use, before rewriting the component definition.
- -- In GNAT mode, this is just a warning, to allow it to be evilly
- -- turned off. Otherwise it is a real error.
+ else
+ declare
+ Desig : Entity_Id;
- if GNAT_Mode then
- Error_Msg_N
- ("??cannot initialize entities of limited type!", Exp);
+ begin
+ Desig := Entity (Subtype_Indication (Type_Def));
- elsif Ada_Version < Ada_2005 then
+ -- If the access definition is to the current record,
+ -- the visible entity at this point is an incomplete
+ -- type. Retrieve the full view to simplify ASIS queries
- -- The side effect removal machinery may generate illegal Ada
- -- code to avoid the usage of access types and 'reference in
- -- SPARK mode. Since this is legal code with respect to theorem
- -- proving, do not emit the error.
+ if Ekind (Desig) = E_Incomplete_Type then
+ Desig := Full_View (Desig);
+ end if;
- if GNATprove_Mode
- and then Nkind (Exp) = N_Function_Call
- and then Nkind (Parent (Exp)) = N_Object_Declaration
- and then not Comes_From_Source
- (Defining_Identifier (Parent (Exp)))
- then
- null;
+ Set_Entity
+ (Subtype_Mark (Access_Definition (Comp_Def)), Desig);
+ end;
+ end if;
- else
- Error_Msg_N
- ("cannot initialize entities of limited type", Exp);
- Explain_Limited_Type (T, Exp);
- end if;
+ Rewrite (Comp_Def,
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Anon_Access, Loc)));
+ if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
+ Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
else
- -- Specialize error message according to kind of illegal
- -- initial expression.
-
- if Nkind (Exp) = N_Type_Conversion
- and then Nkind (Expression (Exp)) = N_Function_Call
- then
- Error_Msg_N
- ("illegal context for call"
- & " to function with limited result", Exp);
-
- else
- Error_Msg_N
- ("initialization of limited object requires aggregate "
- & "or function call", Exp);
- end if;
+ Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
end if;
+
+ Set_Is_Local_Anonymous_Access (Anon_Access);
end if;
+
+ Next (Comp);
+ end loop;
+
+ if Present (Variant_Part (Comp_List)) then
+ declare
+ V : Node_Id;
+ begin
+ V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
+ while Present (V) loop
+ Check_Anonymous_Access_Components
+ (Typ_Decl, Typ, Prev, Component_List (V));
+ Next_Non_Pragma (V);
+ end loop;
+ end;
end if;
- end Check_Initialization;
+ end Check_Anonymous_Access_Components;
----------------------
- -- Check_Interfaces --
+ -- Check_Completion --
----------------------
- procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is
- Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N));
+ procedure Check_Completion (Body_Id : Node_Id := Empty) is
+ E : Entity_Id;
- Iface : Node_Id;
- Iface_Def : Node_Id;
- Iface_Typ : Entity_Id;
- Parent_Node : Node_Id;
+ procedure Post_Error;
+ -- Post error message for lack of completion for entity E
- Is_Task : Boolean := False;
- -- Set True if parent type or any progenitor is a task interface
+ ----------------
+ -- Post_Error --
+ ----------------
- Is_Protected : Boolean := False;
- -- Set True if parent type or any progenitor is a protected interface
+ procedure Post_Error is
- procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
- -- Check that a progenitor is compatible with declaration.
- -- Error is posted on Error_Node.
+ procedure Missing_Body;
+ -- Output missing body message
- ------------------
- -- Check_Ifaces --
- ------------------
+ ------------------
+ -- Missing_Body --
+ ------------------
- procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
- Iface_Id : constant Entity_Id :=
- Defining_Identifier (Parent (Iface_Def));
- Type_Def : Node_Id;
+ procedure Missing_Body is
+ begin
+ -- Spec is in same unit, so we can post on spec
- begin
- if Nkind (N) = N_Private_Extension_Declaration then
- Type_Def := N;
- else
- Type_Def := Type_Definition (N);
- end if;
+ if In_Same_Source_Unit (Body_Id, E) then
+ Error_Msg_N ("missing body for &", E);
- if Is_Task_Interface (Iface_Id) then
- Is_Task := True;
+ -- Spec is in a separate unit, so we have to post on the body
- elsif Is_Protected_Interface (Iface_Id) then
- Is_Protected := True;
- end if;
+ else
+ Error_Msg_NE ("missing body for & declared#!", Body_Id, E);
+ end if;
+ end Missing_Body;
- if Is_Synchronized_Interface (Iface_Id) then
+ -- Start of processing for Post_Error
- -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
- -- extension derived from a synchronized interface must explicitly
- -- be declared synchronized, because the full view will be a
- -- synchronized type.
+ begin
+ if not Comes_From_Source (E) then
- if Nkind (N) = N_Private_Extension_Declaration then
- if not Synchronized_Present (N) then
- Error_Msg_NE
- ("private extension of& must be explicitly synchronized",
- N, Iface_Id);
- end if;
+ if Ekind_In (E, E_Task_Type, E_Protected_Type) then
- -- However, by 3.9.4(16/2), a full type that is a record extension
- -- is never allowed to derive from a synchronized interface (note
- -- that interfaces must be excluded from this check, because those
- -- are represented by derived type definitions in some cases).
+ -- It may be an anonymous protected type created for a
+ -- single variable. Post error on variable, if present.
- elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition
- and then not Interface_Present (Type_Definition (N))
- then
- Error_Msg_N ("record extension cannot derive from synchronized"
- & " interface", Error_Node);
- end if;
- end if;
+ declare
+ Var : Entity_Id;
- -- Check that the characteristics of the progenitor are compatible
- -- with the explicit qualifier in the declaration.
- -- The check only applies to qualifiers that come from source.
- -- Limited_Present also appears in the declaration of corresponding
- -- records, and the check does not apply to them.
+ begin
+ Var := First_Entity (Current_Scope);
+ while Present (Var) loop
+ exit when Etype (Var) = E
+ and then Comes_From_Source (Var);
- if Limited_Present (Type_Def)
- and then not
- Is_Concurrent_Record_Type (Defining_Identifier (N))
- then
- if Is_Limited_Interface (Parent_Type)
- and then not Is_Limited_Interface (Iface_Id)
- then
- Error_Msg_NE
- ("progenitor& must be limited interface",
- Error_Node, Iface_Id);
+ Next_Entity (Var);
+ end loop;
- elsif
- (Task_Present (Iface_Def)
- or else Protected_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def))
- and then Nkind (N) /= N_Private_Extension_Declaration
- and then not Error_Posted (N)
- then
- Error_Msg_NE
- ("progenitor& must be limited interface",
- Error_Node, Iface_Id);
+ if Present (Var) then
+ E := Var;
+ end if;
+ end;
end if;
+ end if;
- -- Protected interfaces can only inherit from limited, synchronized
- -- or protected interfaces.
+ -- If a generated entity has no completion, then either previous
+ -- semantic errors have disabled the expansion phase, or else we had
+ -- missing subunits, or else we are compiling without expansion,
+ -- or else something is very wrong.
- elsif Nkind (N) = N_Full_Type_Declaration
- and then Protected_Present (Type_Def)
- then
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- or else Protected_Present (Iface_Def)
- then
- null;
+ if not Comes_From_Source (E) then
+ pragma Assert
+ (Serious_Errors_Detected > 0
+ or else Configurable_Run_Time_Violations > 0
+ or else Subunits_Missing
+ or else not Expander_Active);
+ return;
- elsif Task_Present (Iface_Def) then
- Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
- & " from task interface", Error_Node);
+ -- Here for source entity
- else
- Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
- & " from non-limited interface", Error_Node);
- end if;
+ else
+ -- Here if no body to post the error message, so we post the error
+ -- on the declaration that has no completion. This is not really
+ -- the right place to post it, think about this later ???
- -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from
- -- limited and synchronized.
+ if No (Body_Id) then
+ if Is_Type (E) then
+ Error_Msg_NE
+ ("missing full declaration for }", Parent (E), E);
+ else
+ Error_Msg_NE ("missing body for &", Parent (E), E);
+ end if;
- elsif Synchronized_Present (Type_Def) then
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- then
- null;
+ -- Package body has no completion for a declaration that appears
+ -- in the corresponding spec. Post error on the body, with a
+ -- reference to the non-completed declaration.
- elsif Protected_Present (Iface_Def)
- and then Nkind (N) /= N_Private_Extension_Declaration
- then
- Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
- & " from protected interface", Error_Node);
+ else
+ Error_Msg_Sloc := Sloc (E);
- elsif Task_Present (Iface_Def)
- and then Nkind (N) /= N_Private_Extension_Declaration
- then
- Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
- & " from task interface", Error_Node);
+ if Is_Type (E) then
+ Error_Msg_NE ("missing full declaration for }!", Body_Id, E);
- elsif not Is_Limited_Interface (Iface_Id) then
- Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
- & " from non-limited interface", Error_Node);
- end if;
+ elsif Is_Overloadable (E)
+ and then Current_Entity_In_Scope (E) /= E
+ then
+ -- It may be that the completion is mistyped and appears as
+ -- a distinct overloading of the entity.
- -- Ada 2005 (AI-345): Task interfaces can only inherit from limited,
- -- synchronized or task interfaces.
+ declare
+ Candidate : constant Entity_Id :=
+ Current_Entity_In_Scope (E);
+ Decl : constant Node_Id :=
+ Unit_Declaration_Node (Candidate);
- elsif Nkind (N) = N_Full_Type_Declaration
- and then Task_Present (Type_Def)
- then
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- or else Task_Present (Iface_Def)
- then
- null;
+ begin
+ if Is_Overloadable (Candidate)
+ and then Ekind (Candidate) = Ekind (E)
+ and then Nkind (Decl) = N_Subprogram_Body
+ and then Acts_As_Spec (Decl)
+ then
+ Check_Type_Conformant (Candidate, E);
- elsif Protected_Present (Iface_Def) then
- Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
- & " protected interface", Error_Node);
+ else
+ Missing_Body;
+ end if;
+ end;
- else
- Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
- & " non-limited interface", Error_Node);
+ else
+ Missing_Body;
+ end if;
end if;
end if;
- end Check_Ifaces;
+ end Post_Error;
- -- Start of processing for Check_Interfaces
+ -- Local variables
+
+ Pack_Id : constant Entity_Id := Current_Scope;
+
+ -- Start of processing for Check_Completion
begin
- if Is_Interface (Parent_Type) then
- if Is_Task_Interface (Parent_Type) then
- Is_Task := True;
+ E := First_Entity (Pack_Id);
+ while Present (E) loop
+ if Is_Intrinsic_Subprogram (E) then
+ null;
- elsif Is_Protected_Interface (Parent_Type) then
- Is_Protected := True;
- end if;
- end if;
+ -- The following situation requires special handling: a child unit
+ -- that appears in the context clause of the body of its parent:
- if Nkind (N) = N_Private_Extension_Declaration then
+ -- procedure Parent.Child (...);
- -- Check that progenitors are compatible with declaration
+ -- with Parent.Child;
+ -- package body Parent is
- Iface := First (Interface_List (Def));
- while Present (Iface) loop
- Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+ -- Here Parent.Child appears as a local entity, but should not be
+ -- flagged as requiring completion, because it is a compilation
+ -- unit.
- Parent_Node := Parent (Base_Type (Iface_Typ));
- Iface_Def := Type_Definition (Parent_Node);
+ -- Ignore missing completion for a subprogram that does not come from
+ -- source (including the _Call primitive operation of RAS types,
+ -- which has to have the flag Comes_From_Source for other purposes):
+ -- we assume that the expander will provide the missing completion.
+ -- In case of previous errors, other expansion actions that provide
+ -- bodies for null procedures with not be invoked, so inhibit message
+ -- in those cases.
- if not Is_Interface (Iface_Typ) then
- Diagnose_Interface (Iface, Iface_Typ);
+ -- Note that E_Operator is not in the list that follows, because
+ -- this kind is reserved for predefined operators, that are
+ -- intrinsic and do not need completion.
+
+ elsif Ekind_In (E, E_Function,
+ E_Procedure,
+ E_Generic_Function,
+ E_Generic_Procedure)
+ then
+ if Has_Completion (E) then
+ null;
+
+ elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
+ null;
+
+ elsif Is_Subprogram (E)
+ and then (not Comes_From_Source (E)
+ or else Chars (E) = Name_uCall)
+ then
+ null;
+
+ elsif
+ Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
+ then
+ null;
+
+ elsif Nkind (Parent (E)) = N_Procedure_Specification
+ and then Null_Present (Parent (E))
+ and then Serious_Errors_Detected > 0
+ then
+ null;
else
- Check_Ifaces (Iface_Def, Iface);
+ Post_Error;
end if;
- Next (Iface);
- end loop;
+ elsif Is_Entry (E) then
+ if not Has_Completion (E) and then
+ (Ekind (Scope (E)) = E_Protected_Object
+ or else Ekind (Scope (E)) = E_Protected_Type)
+ then
+ Post_Error;
+ end if;
- if Is_Task and Is_Protected then
- Error_Msg_N
- ("type cannot derive from task and protected interface", N);
- end if;
+ elsif Is_Package_Or_Generic_Package (E) then
+ if Unit_Requires_Body (E) then
+ if not Has_Completion (E)
+ and then Nkind (Parent (Unit_Declaration_Node (E))) /=
+ N_Compilation_Unit
+ then
+ Post_Error;
+ end if;
- return;
- end if;
+ elsif not Is_Child_Unit (E) then
+ May_Need_Implicit_Body (E);
+ end if;
- -- Full type declaration of derived type.
- -- Check compatibility with parent if it is interface type
+ -- A formal incomplete type (Ada 2012) does not require a completion;
+ -- other incomplete type declarations do.
- if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
- and then Is_Interface (Parent_Type)
- then
- Parent_Node := Parent (Parent_Type);
+ elsif Ekind (E) = E_Incomplete_Type
+ and then No (Underlying_Type (E))
+ and then not Is_Generic_Type (E)
+ then
+ Post_Error;
- -- More detailed checks for interface varieties
+ elsif Ekind_In (E, E_Task_Type, E_Protected_Type)
+ and then not Has_Completion (E)
+ then
+ Post_Error;
- Check_Ifaces
- (Iface_Def => Type_Definition (Parent_Node),
- Error_Node => Subtype_Indication (Type_Definition (N)));
- end if;
+ -- A single task declared in the current scope is a constant, verify
+ -- that the body of its anonymous type is in the same scope. If the
+ -- task is defined elsewhere, this may be a renaming declaration for
+ -- which no completion is needed.
- Iface := First (Interface_List (Def));
- while Present (Iface) loop
- Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+ elsif Ekind (E) = E_Constant
+ and then Ekind (Etype (E)) = E_Task_Type
+ and then not Has_Completion (Etype (E))
+ and then Scope (Etype (E)) = Current_Scope
+ then
+ Post_Error;
- Parent_Node := Parent (Base_Type (Iface_Typ));
- Iface_Def := Type_Definition (Parent_Node);
+ elsif Ekind (E) = E_Protected_Object
+ and then not Has_Completion (Etype (E))
+ then
+ Post_Error;
- if not Is_Interface (Iface_Typ) then
- Diagnose_Interface (Iface, Iface_Typ);
+ elsif Ekind (E) = E_Record_Type then
+ if Is_Tagged_Type (E) then
+ Check_Abstract_Overriding (E);
+ Check_Conventions (E);
+ end if;
- else
- -- "The declaration of a specific descendant of an interface
- -- type freezes the interface type" RM 13.14
+ Check_Aliased_Component_Types (E);
+
+ elsif Ekind (E) = E_Array_Type then
+ Check_Aliased_Component_Types (E);
- Freeze_Before (N, Iface_Typ);
- Check_Ifaces (Iface_Def, Error_Node => Iface);
end if;
- Next (Iface);
+ Next_Entity (E);
end loop;
-
- if Is_Task and Is_Protected then
- Error_Msg_N
- ("type cannot derive from task and protected interface", N);
- end if;
- end Check_Interfaces;
+ end Check_Completion;
------------------------------------
- -- Check_Or_Process_Discriminants --
+ -- Check_CPP_Type_Has_No_Defaults --
------------------------------------
- -- If an incomplete or private type declaration was already given for the
- -- type, the discriminants may have already been processed if they were
- -- present on the incomplete declaration. In this case a full conformance
- -- check has been performed in Find_Type_Name, and we then recheck here
- -- some properties that can't be checked on the partial view alone.
- -- Otherwise we call Process_Discriminants.
+ procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is
+ Tdef : constant Node_Id := Type_Definition (Declaration_Node (T));
+ Clist : Node_Id;
+ Comp : Node_Id;
- procedure Check_Or_Process_Discriminants
- (N : Node_Id;
- T : Entity_Id;
- Prev : Entity_Id := Empty)
- is
begin
- if Has_Discriminants (T) then
+ -- Obtain the component list
- -- Discriminants are already set on T if they were already present
- -- on the partial view. Make them visible to component declarations.
+ if Nkind (Tdef) = N_Record_Definition then
+ Clist := Component_List (Tdef);
+ else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
+ Clist := Component_List (Record_Extension_Part (Tdef));
+ end if;
- declare
- D : Entity_Id;
- -- Discriminant on T (full view) referencing expr on partial view
+ -- Check all components to ensure no default expressions
- Prev_D : Entity_Id;
- -- Entity of corresponding discriminant on partial view
-
- New_D : Node_Id;
- -- Discriminant specification for full view, expression is the
- -- syntactic copy on full view (which has been checked for
- -- conformance with partial view), only used here to post error
- -- message.
-
- begin
- D := First_Discriminant (T);
- New_D := First (Discriminant_Specifications (N));
- while Present (D) loop
- Prev_D := Current_Entity (D);
- Set_Current_Entity (D);
- Set_Is_Immediately_Visible (D);
- Set_Homonym (D, Prev_D);
-
- -- Handle the case where there is an untagged partial view and
- -- the full view is tagged: must disallow discriminants with
- -- defaults, unless compiling for Ada 2012, which allows a
- -- limited tagged type to have defaulted discriminants (see
- -- AI05-0214). However, suppress error here if it was already
- -- reported on the default expression of the partial view.
-
- if Is_Tagged_Type (T)
- and then Present (Expression (Parent (D)))
- and then (not Is_Limited_Type (Current_Scope)
- or else Ada_Version < Ada_2012)
- and then not Error_Posted (Expression (Parent (D)))
- then
- if Ada_Version >= Ada_2012 then
- Error_Msg_N
- ("discriminants of nonlimited tagged type cannot have"
- & " defaults",
- Expression (New_D));
- else
- Error_Msg_N
- ("discriminants of tagged type cannot have defaults",
- Expression (New_D));
- end if;
- end if;
-
- -- Ada 2005 (AI-230): Access discriminant allowed in
- -- non-limited record types.
-
- if Ada_Version < Ada_2005 then
-
- -- This restriction gets applied to the full type here. It
- -- has already been applied earlier to the partial view.
-
- Check_Access_Discriminant_Requires_Limited (Parent (D), N);
- end if;
-
- Next_Discriminant (D);
- Next (New_D);
- end loop;
- end;
+ if Present (Clist) then
+ Comp := First (Component_Items (Clist));
+ while Present (Comp) loop
+ if Present (Expression (Comp)) then
+ Error_Msg_N
+ ("component of imported 'C'P'P type cannot have "
+ & "default expression", Expression (Comp));
+ end if;
- elsif Present (Discriminant_Specifications (N)) then
- Process_Discriminants (N, Prev);
+ Next (Comp);
+ end loop;
end if;
- end Check_Or_Process_Discriminants;
+ end Check_CPP_Type_Has_No_Defaults;
- ----------------------
- -- Check_Real_Bound --
- ----------------------
+ ----------------------------
+ -- Check_Delta_Expression --
+ ----------------------------
- procedure Check_Real_Bound (Bound : Node_Id) is
+ procedure Check_Delta_Expression (E : Node_Id) is
begin
- if not Is_Real_Type (Etype (Bound)) then
- Error_Msg_N
- ("bound in real type definition must be of real type", Bound);
+ if not (Is_Real_Type (Etype (E))) then
+ Wrong_Type (E, Any_Real);
- elsif not Is_OK_Static_Expression (Bound) then
+ elsif not Is_OK_Static_Expression (E) then
Flag_Non_Static_Expr
- ("non-static expression used for real type bound!", Bound);
+ ("non-static expression used for delta value!", E);
+
+ elsif not UR_Is_Positive (Expr_Value_R (E)) then
+ Error_Msg_N ("delta expression must be positive", E);
else
return;
end if;
- Rewrite
- (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0));
- Analyze (Bound);
- Resolve (Bound, Standard_Float);
- end Check_Real_Bound;
+ -- If any of above errors occurred, then replace the incorrect
+ -- expression by the real 0.1, which should prevent further errors.
- ------------------------------
- -- Complete_Private_Subtype --
- ------------------------------
+ Rewrite (E,
+ Make_Real_Literal (Sloc (E), Ureal_Tenth));
+ Analyze_And_Resolve (E, Standard_Float);
+ end Check_Delta_Expression;
- procedure Complete_Private_Subtype
- (Priv : Entity_Id;
- Full : Entity_Id;
- Full_Base : Entity_Id;
- Related_Nod : Node_Id)
- is
- Save_Next_Entity : Entity_Id;
- Save_Homonym : Entity_Id;
+ -----------------------------
+ -- Check_Digits_Expression --
+ -----------------------------
+ procedure Check_Digits_Expression (E : Node_Id) is
begin
- -- Set semantic attributes for (implicit) private subtype completion.
- -- If the full type has no discriminants, then it is a copy of the full
- -- view of the base. Otherwise, it is a subtype of the base with a
- -- possible discriminant constraint. Save and restore the original
- -- Next_Entity field of full to ensure that the calls to Copy_Node
- -- do not corrupt the entity chain.
-
- -- Note that the type of the full view is the same entity as the type of
- -- the partial view. In this fashion, the subtype has access to the
- -- correct view of the parent.
-
- Save_Next_Entity := Next_Entity (Full);
- Save_Homonym := Homonym (Priv);
+ if not (Is_Integer_Type (Etype (E))) then
+ Wrong_Type (E, Any_Integer);
- case Ekind (Full_Base) is
- when E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- Private_Kind |
- Task_Kind |
- Protected_Kind =>
- Copy_Node (Priv, Full);
+ elsif not Is_OK_Static_Expression (E) then
+ Flag_Non_Static_Expr
+ ("non-static expression used for digits value!", E);
- Set_Has_Discriminants
- (Full, Has_Discriminants (Full_Base));
- Set_Has_Unknown_Discriminants
- (Full, Has_Unknown_Discriminants (Full_Base));
- Set_First_Entity (Full, First_Entity (Full_Base));
- Set_Last_Entity (Full, Last_Entity (Full_Base));
+ elsif Expr_Value (E) <= 0 then
+ Error_Msg_N ("digits value must be greater than zero", E);
- -- If the underlying base type is constrained, we know that the
- -- full view of the subtype is constrained as well (the converse
- -- is not necessarily true).
+ else
+ return;
+ end if;
- if Is_Constrained (Full_Base) then
- Set_Is_Constrained (Full);
- end if;
+ -- If any of above errors occurred, then replace the incorrect
+ -- expression by the integer 1, which should prevent further errors.
- when others =>
- Copy_Node (Full_Base, Full);
+ Rewrite (E, Make_Integer_Literal (Sloc (E), 1));
+ Analyze_And_Resolve (E, Standard_Integer);
- Set_Chars (Full, Chars (Priv));
- Conditional_Delay (Full, Priv);
- Set_Sloc (Full, Sloc (Priv));
- end case;
+ end Check_Digits_Expression;
- Set_Next_Entity (Full, Save_Next_Entity);
- Set_Homonym (Full, Save_Homonym);
- Set_Associated_Node_For_Itype (Full, Related_Nod);
+ --------------------------
+ -- Check_Initialization --
+ --------------------------
- -- Set common attributes for all subtypes: kind, convention, etc.
+ procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
+ begin
+ -- Special processing for limited types
- Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
- Set_Convention (Full, Convention (Full_Base));
+ if Is_Limited_Type (T)
+ and then not In_Instance
+ and then not In_Inlined_Body
+ then
+ if not OK_For_Limited_Init (T, Exp) then
- -- The Etype of the full view is inconsistent. Gigi needs to see the
- -- structural full view, which is what the current scheme gives:
- -- the Etype of the full view is the etype of the full base. However,
- -- if the full base is a derived type, the full view then looks like
- -- a subtype of the parent, not a subtype of the full base. If instead
- -- we write:
+ -- In GNAT mode, this is just a warning, to allow it to be evilly
+ -- turned off. Otherwise it is a real error.
- -- Set_Etype (Full, Full_Base);
+ if GNAT_Mode then
+ Error_Msg_N
+ ("??cannot initialize entities of limited type!", Exp);
- -- then we get inconsistencies in the front-end (confusion between
- -- views). Several outstanding bugs are related to this ???
+ elsif Ada_Version < Ada_2005 then
- Set_Is_First_Subtype (Full, False);
- Set_Scope (Full, Scope (Priv));
- Set_Size_Info (Full, Full_Base);
- Set_RM_Size (Full, RM_Size (Full_Base));
- Set_Is_Itype (Full);
+ -- The side effect removal machinery may generate illegal Ada
+ -- code to avoid the usage of access types and 'reference in
+ -- SPARK mode. Since this is legal code with respect to theorem
+ -- proving, do not emit the error.
- -- A subtype of a private-type-without-discriminants, whose full-view
- -- has discriminants with default expressions, is not constrained.
+ if GNATprove_Mode
+ and then Nkind (Exp) = N_Function_Call
+ and then Nkind (Parent (Exp)) = N_Object_Declaration
+ and then not Comes_From_Source
+ (Defining_Identifier (Parent (Exp)))
+ then
+ null;
- if not Has_Discriminants (Priv) then
- Set_Is_Constrained (Full, Is_Constrained (Full_Base));
+ else
+ Error_Msg_N
+ ("cannot initialize entities of limited type", Exp);
+ Explain_Limited_Type (T, Exp);
+ end if;
- if Has_Discriminants (Full_Base) then
- Set_Discriminant_Constraint
- (Full, Discriminant_Constraint (Full_Base));
+ else
+ -- Specialize error message according to kind of illegal
+ -- initial expression.
- -- The partial view may have been indefinite, the full view
- -- might not be.
+ if Nkind (Exp) = N_Type_Conversion
+ and then Nkind (Expression (Exp)) = N_Function_Call
+ then
+ Error_Msg_N
+ ("illegal context for call"
+ & " to function with limited result", Exp);
- Set_Has_Unknown_Discriminants
- (Full, Has_Unknown_Discriminants (Full_Base));
+ else
+ Error_Msg_N
+ ("initialization of limited object requires aggregate "
+ & "or function call", Exp);
+ end if;
+ end if;
end if;
end if;
- Set_First_Rep_Item (Full, First_Rep_Item (Full_Base));
- Set_Depends_On_Private (Full, Has_Private_Component (Full));
-
- -- Freeze the private subtype entity if its parent is delayed, and not
- -- already frozen. We skip this processing if the type is an anonymous
- -- subtype of a record component, or is the corresponding record of a
- -- protected type, since ???
+ -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets
+ -- set unless we can be sure that no range check is required.
- if not Is_Type (Scope (Full)) then
- Set_Has_Delayed_Freeze (Full,
- Has_Delayed_Freeze (Full_Base)
- and then (not Is_Frozen (Full_Base)));
+ if (GNATprove_Mode or not Expander_Active)
+ and then Is_Scalar_Type (T)
+ and then not Is_In_Range (Exp, T, Assume_Valid => True)
+ then
+ Set_Do_Range_Check (Exp);
end if;
+ end Check_Initialization;
- Set_Freeze_Node (Full, Empty);
- Set_Is_Frozen (Full, False);
- Set_Full_View (Priv, Full);
+ ----------------------
+ -- Check_Interfaces --
+ ----------------------
- if Has_Discriminants (Full) then
- Set_Stored_Constraint_From_Discriminant_Constraint (Full);
- Set_Stored_Constraint (Priv, Stored_Constraint (Full));
+ procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is
+ Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N));
- 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) -- might not, if errors
- and then not Has_Unknown_Discriminants (Priv)
- and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
- then
- Create_Constrained_Components
- (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
-
- -- If the full base is itself derived from private, build a congruent
- -- subtype of its underlying type, for use by the back end. For a
- -- constrained record component, the declaration cannot be placed on
- -- the component list, but it must nevertheless be built an analyzed, to
- -- supply enough information for Gigi to compute the size of component.
-
- elsif Ekind (Full_Base) in Private_Kind
- and then Is_Derived_Type (Full_Base)
- and then Has_Discriminants (Full_Base)
- and then (Ekind (Current_Scope) /= E_Record_Subtype)
- then
- if not Is_Itype (Priv)
- and then
- Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
- then
- Build_Underlying_Full_View
- (Parent (Priv), Full, Etype (Full_Base));
+ Iface : Node_Id;
+ Iface_Def : Node_Id;
+ Iface_Typ : Entity_Id;
+ Parent_Node : Node_Id;
- elsif Nkind (Related_Nod) = N_Component_Declaration then
- Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
- end if;
+ Is_Task : Boolean := False;
+ -- Set True if parent type or any progenitor is a task interface
- elsif Is_Record_Type (Full_Base) then
+ Is_Protected : Boolean := False;
+ -- Set True if parent type or any progenitor is a protected interface
- -- Show Full is simply a renaming of Full_Base
+ procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
+ -- Check that a progenitor is compatible with declaration. If an error
+ -- message is output, it is posted on Error_Node.
- Set_Cloned_Subtype (Full, Full_Base);
- end if;
+ ------------------
+ -- Check_Ifaces --
+ ------------------
- -- It is unsafe to share the bounds of a scalar type, because the Itype
- -- is elaborated on demand, and if a bound is non-static then different
- -- orders of elaboration in different units will lead to different
- -- external symbols.
+ procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
+ Iface_Id : constant Entity_Id :=
+ Defining_Identifier (Parent (Iface_Def));
+ Type_Def : Node_Id;
- if Is_Scalar_Type (Full_Base) then
- Set_Scalar_Range (Full,
- Make_Range (Sloc (Related_Nod),
- Low_Bound =>
- Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)),
- High_Bound =>
- Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base))));
+ begin
+ if Nkind (N) = N_Private_Extension_Declaration then
+ Type_Def := N;
+ else
+ Type_Def := Type_Definition (N);
+ end if;
- -- This completion inherits the bounds of the full parent, but if
- -- the parent is an unconstrained floating point type, so is the
- -- completion.
+ if Is_Task_Interface (Iface_Id) then
+ Is_Task := True;
- if Is_Floating_Point_Type (Full_Base) then
- Set_Includes_Infinities
- (Scalar_Range (Full), Has_Infinities (Full_Base));
+ elsif Is_Protected_Interface (Iface_Id) then
+ Is_Protected := True;
end if;
- end if;
- -- ??? It seems that a lot of fields are missing that should be copied
- -- from Full_Base to Full. Here are some that are introduced in a
- -- non-disruptive way but a cleanup is necessary.
+ if Is_Synchronized_Interface (Iface_Id) then
- if Is_Tagged_Type (Full_Base) then
- Set_Is_Tagged_Type (Full);
- Set_Direct_Primitive_Operations (Full,
- Direct_Primitive_Operations (Full_Base));
+ -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private
+ -- extension derived from a synchronized interface must explicitly
+ -- be declared synchronized, because the full view will be a
+ -- synchronized type.
- -- Inherit class_wide type of full_base in case the partial view was
- -- not tagged. Otherwise it has already been created when the private
- -- subtype was analyzed.
+ if Nkind (N) = N_Private_Extension_Declaration then
+ if not Synchronized_Present (N) then
+ Error_Msg_NE
+ ("private extension of& must be explicitly synchronized",
+ N, Iface_Id);
+ end if;
- if No (Class_Wide_Type (Full)) then
- Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base));
+ -- However, by 3.9.4(16/2), a full type that is a record extension
+ -- is never allowed to derive from a synchronized interface (note
+ -- that interfaces must be excluded from this check, because those
+ -- are represented by derived type definitions in some cases).
+
+ elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition
+ and then not Interface_Present (Type_Definition (N))
+ then
+ Error_Msg_N ("record extension cannot derive from synchronized "
+ & "interface", Error_Node);
+ end if;
end if;
- -- If this is a subtype of a protected or task type, constrain its
- -- corresponding record, unless this is a subtype without constraints,
- -- i.e. a simple renaming as with an actual subtype in an instance.
+ -- Check that the characteristics of the progenitor are compatible
+ -- with the explicit qualifier in the declaration.
+ -- The check only applies to qualifiers that come from source.
+ -- Limited_Present also appears in the declaration of corresponding
+ -- records, and the check does not apply to them.
- elsif Is_Concurrent_Type (Full_Base) then
- if Has_Discriminants (Full)
- and then Present (Corresponding_Record_Type (Full_Base))
- and then
- not Is_Empty_Elmt_List (Discriminant_Constraint (Full))
+ if Limited_Present (Type_Def)
+ and then not
+ Is_Concurrent_Record_Type (Defining_Identifier (N))
then
- Set_Corresponding_Record_Type (Full,
- Constrain_Corresponding_Record
- (Full, Corresponding_Record_Type (Full_Base), Related_Nod));
+ if Is_Limited_Interface (Parent_Type)
+ and then not Is_Limited_Interface (Iface_Id)
+ then
+ Error_Msg_NE
+ ("progenitor & must be limited interface",
+ Error_Node, Iface_Id);
- else
- Set_Corresponding_Record_Type (Full,
- Corresponding_Record_Type (Full_Base));
- end if;
- end if;
+ elsif
+ (Task_Present (Iface_Def)
+ or else Protected_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def))
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ and then not Error_Posted (N)
+ then
+ Error_Msg_NE
+ ("progenitor & must be limited interface",
+ Error_Node, Iface_Id);
+ end if;
- -- Link rep item chain, and also setting of Has_Predicates from private
- -- subtype to full subtype, since we will need these on the full subtype
- -- to create the predicate function. Note that the full subtype may
- -- already have rep items, inherited from the full view of the base
- -- type, so we must be sure not to overwrite these entries.
+ -- Protected interfaces can only inherit from limited, synchronized
+ -- or protected interfaces.
- declare
- Append : Boolean;
- Item : Node_Id;
- Next_Item : Node_Id;
+ elsif Nkind (N) = N_Full_Type_Declaration
+ and then Protected_Present (Type_Def)
+ then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Protected_Present (Iface_Def)
+ then
+ null;
- begin
- Item := First_Rep_Item (Full);
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) protected interface cannot inherit "
+ & "from task interface", Error_Node);
- -- If no existing rep items on full type, we can just link directly
- -- to the list of items on the private type.
+ else
+ Error_Msg_N ("(Ada 2005) protected interface cannot inherit "
+ & "from non-limited interface", Error_Node);
+ end if;
- if No (Item) then
- Set_First_Rep_Item (Full, First_Rep_Item (Priv));
+ -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from
+ -- limited and synchronized.
- -- Otherwise, search to the end of items currently linked to the full
- -- subtype and append the private items to the end. However, if Priv
- -- and Full already have the same list of rep items, then the append
- -- is not done, as that would create a circularity.
+ elsif Synchronized_Present (Type_Def) then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ then
+ null;
- elsif Item /= First_Rep_Item (Priv) then
- Append := True;
+ elsif Protected_Present (Iface_Def)
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ then
+ Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit "
+ & "from protected interface", Error_Node);
- loop
- Next_Item := Next_Rep_Item (Item);
- exit when No (Next_Item);
- Item := Next_Item;
+ elsif Task_Present (Iface_Def)
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ then
+ Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit "
+ & "from task interface", Error_Node);
- -- If the private view has aspect specifications, the full view
- -- inherits them. Since these aspects may already have been
- -- attached to the full view during derivation, do not append
- -- them if already present.
+ elsif not Is_Limited_Interface (Iface_Id) then
+ Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit "
+ & "from non-limited interface", Error_Node);
+ end if;
- if Item = First_Rep_Item (Priv) then
- Append := False;
- exit;
- end if;
- end loop;
+ -- Ada 2005 (AI-345): Task interfaces can only inherit from limited,
+ -- synchronized or task interfaces.
- -- And link the private type items at the end of the chain
+ elsif Nkind (N) = N_Full_Type_Declaration
+ and then Task_Present (Type_Def)
+ then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Task_Present (Iface_Def)
+ then
+ null;
- if Append then
- Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) task interface cannot inherit from "
+ & "protected interface", Error_Node);
+
+ else
+ Error_Msg_N ("(Ada 2005) task interface cannot inherit from "
+ & "non-limited interface", Error_Node);
end if;
end if;
- end;
+ end Check_Ifaces;
- -- Make sure Has_Predicates is set on full type if it is set on the
- -- private type. Note that it may already be set on the full type and
- -- if so, we don't want to unset it.
+ -- Start of processing for Check_Interfaces
- if Has_Predicates (Priv) then
- Set_Has_Predicates (Full);
+ begin
+ if Is_Interface (Parent_Type) then
+ if Is_Task_Interface (Parent_Type) then
+ Is_Task := True;
+
+ elsif Is_Protected_Interface (Parent_Type) then
+ Is_Protected := True;
+ end if;
end if;
- end Complete_Private_Subtype;
- ----------------------------
- -- Constant_Redeclaration --
- ----------------------------
+ if Nkind (N) = N_Private_Extension_Declaration then
- 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;
+ -- Check that progenitors are compatible with declaration
- procedure Check_Possible_Deferred_Completion
- (Prev_Id : Entity_Id;
- Prev_Obj_Def : Node_Id;
- Curr_Obj_Def : Node_Id);
- -- Determine whether the two object definitions describe the partial
- -- and the full view of a constrained deferred constant. Generate
- -- a subtype for the full view and verify that it statically matches
- -- the subtype of the partial view.
-
- procedure Check_Recursive_Declaration (Typ : Entity_Id);
- -- If deferred constant is an access type initialized with an allocator,
- -- check whether there is an illegal recursion in the definition,
- -- through a default value of some record subcomponent. This is normally
- -- detected when generating init procs, but requires this additional
- -- mechanism when expansion is disabled.
+ Iface := First (Interface_List (Def));
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
- ----------------------------------------
- -- Check_Possible_Deferred_Completion --
- ----------------------------------------
+ Parent_Node := Parent (Base_Type (Iface_Typ));
+ Iface_Def := Type_Definition (Parent_Node);
- procedure Check_Possible_Deferred_Completion
- (Prev_Id : Entity_Id;
- Prev_Obj_Def : Node_Id;
- Curr_Obj_Def : Node_Id)
- is
- begin
- if Nkind (Prev_Obj_Def) = N_Subtype_Indication
- and then Present (Constraint (Prev_Obj_Def))
- and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
- and then Present (Constraint (Curr_Obj_Def))
- then
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
- Decl : constant Node_Id :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Indication =>
- Relocate_Node (Curr_Obj_Def));
+ if not Is_Interface (Iface_Typ) then
+ Diagnose_Interface (Iface, Iface_Typ);
+ else
+ Check_Ifaces (Iface_Def, Iface);
+ end if;
- begin
- Insert_Before_And_Analyze (N, Decl);
- Set_Etype (Id, Def_Id);
+ Next (Iface);
+ end loop;
- if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
- Error_Msg_Sloc := Sloc (Prev_Id);
- Error_Msg_N ("subtype does not statically match deferred " &
- "declaration#", N);
- end if;
- end;
+ if Is_Task and Is_Protected then
+ Error_Msg_N
+ ("type cannot derive from task and protected interface", N);
end if;
- end Check_Possible_Deferred_Completion;
-
- ---------------------------------
- -- Check_Recursive_Declaration --
- ---------------------------------
- procedure Check_Recursive_Declaration (Typ : Entity_Id) is
- Comp : Entity_Id;
-
- begin
- if Is_Record_Type (Typ) then
- Comp := First_Component (Typ);
- while Present (Comp) loop
- if Comes_From_Source (Comp) then
- if Present (Expression (Parent (Comp)))
- and then Is_Entity_Name (Expression (Parent (Comp)))
- and then Entity (Expression (Parent (Comp))) = Prev
- then
- Error_Msg_Sloc := Sloc (Parent (Comp));
- Error_Msg_NE
- ("illegal circularity with declaration for&#",
- N, Comp);
- return;
+ return;
+ end if;
- elsif Is_Record_Type (Etype (Comp)) then
- Check_Recursive_Declaration (Etype (Comp));
- end if;
- end if;
+ -- Full type declaration of derived type.
+ -- Check compatibility with parent if it is interface type
- Next_Component (Comp);
- end loop;
- end if;
- end Check_Recursive_Declaration;
+ if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
+ and then Is_Interface (Parent_Type)
+ then
+ Parent_Node := Parent (Parent_Type);
- -- Start of processing for Constant_Redeclaration
+ -- More detailed checks for interface varieties
- begin
- if Nkind (Parent (Prev)) = N_Object_Declaration then
- if Nkind (Object_Definition
- (Parent (Prev))) = N_Subtype_Indication
- then
- -- Find type of new declaration. The constraints of the two
- -- views must match statically, but there is no point in
- -- creating an itype for the full view.
+ Check_Ifaces
+ (Iface_Def => Type_Definition (Parent_Node),
+ Error_Node => Subtype_Indication (Type_Definition (N)));
+ end if;
- if Nkind (Obj_Def) = N_Subtype_Indication then
- Find_Type (Subtype_Mark (Obj_Def));
- New_T := Entity (Subtype_Mark (Obj_Def));
+ Iface := First (Interface_List (Def));
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
- else
- Find_Type (Obj_Def);
- New_T := Entity (Obj_Def);
- end if;
+ Parent_Node := Parent (Base_Type (Iface_Typ));
+ Iface_Def := Type_Definition (Parent_Node);
- T := Etype (Prev);
+ if not Is_Interface (Iface_Typ) then
+ Diagnose_Interface (Iface, Iface_Typ);
else
- -- The full view may impose a constraint, even if the partial
- -- view does not, so construct the subtype.
+ -- "The declaration of a specific descendant of an interface
+ -- type freezes the interface type" RM 13.14
- New_T := Find_Type_Of_Object (Obj_Def, N);
- T := New_T;
+ Freeze_Before (N, Iface_Typ);
+ Check_Ifaces (Iface_Def, Error_Node => Iface);
end if;
- else
- -- Current declaration is illegal, diagnosed below in Enter_Name
+ Next (Iface);
+ end loop;
- T := Empty;
- New_T := Any_Type;
+ if Is_Task and Is_Protected then
+ Error_Msg_N
+ ("type cannot derive from task and protected interface", N);
end if;
+ end Check_Interfaces;
- -- If previous full declaration or a renaming declaration exists, or if
- -- a homograph is present, let Enter_Name handle it, either with an
- -- error or with the removal of an overridden implicit subprogram.
- -- The previous one is a full declaration if it has an expression
- -- (which in the case of an aggregate is indicated by the Init flag).
+ ------------------------------------
+ -- Check_Or_Process_Discriminants --
+ ------------------------------------
- if Ekind (Prev) /= E_Constant
- or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration
- or else Present (Expression (Parent (Prev)))
- or else Has_Init_Expression (Parent (Prev))
- or else Present (Full_View (Prev))
- then
- Enter_Name (Id);
+ -- If an incomplete or private type declaration was already given for the
+ -- type, the discriminants may have already been processed if they were
+ -- present on the incomplete declaration. In this case a full conformance
+ -- check has been performed in Find_Type_Name, and we then recheck here
+ -- some properties that can't be checked on the partial view alone.
+ -- Otherwise we call Process_Discriminants.
- -- Verify that types of both declarations match, or else that both types
- -- are anonymous access types whose designated subtypes statically match
- -- (as allowed in Ada 2005 by AI-385).
+ procedure Check_Or_Process_Discriminants
+ (N : Node_Id;
+ T : Entity_Id;
+ Prev : Entity_Id := Empty)
+ is
+ begin
+ if Has_Discriminants (T) then
- elsif Base_Type (Etype (Prev)) /= Base_Type (New_T)
- and then
- (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type
- or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type
- or else Is_Access_Constant (Etype (New_T)) /=
- Is_Access_Constant (Etype (Prev))
- or else Can_Never_Be_Null (Etype (New_T)) /=
- Can_Never_Be_Null (Etype (Prev))
- or else Null_Exclusion_Present (Parent (Prev)) /=
- Null_Exclusion_Present (Parent (Id))
- or else not Subtypes_Statically_Match
- (Designated_Type (Etype (Prev)),
- Designated_Type (Etype (New_T))))
- then
- Error_Msg_Sloc := Sloc (Prev);
- Error_Msg_N ("type does not match declaration#", N);
- Set_Full_View (Prev, Id);
- Set_Etype (Id, Any_Type);
+ -- Discriminants are already set on T if they were already present
+ -- on the partial view. Make them visible to component declarations.
- elsif
- Null_Exclusion_Present (Parent (Prev))
- and then not Null_Exclusion_Present (N)
- then
- Error_Msg_Sloc := Sloc (Prev);
- Error_Msg_N ("null-exclusion does not match declaration#", N);
- Set_Full_View (Prev, Id);
- Set_Etype (Id, Any_Type);
+ declare
+ D : Entity_Id;
+ -- Discriminant on T (full view) referencing expr on partial view
- -- If so, process the full constant declaration
+ Prev_D : Entity_Id;
+ -- Entity of corresponding discriminant on partial view
- else
- -- RM 7.4 (6): If the subtype defined by the subtype_indication in
- -- the deferred declaration is constrained, then the subtype defined
- -- by the subtype_indication in the full declaration shall match it
- -- statically.
+ New_D : Node_Id;
+ -- Discriminant specification for full view, expression is
+ -- the syntactic copy on full view (which has been checked for
+ -- conformance with partial view), only used here to post error
+ -- message.
- Check_Possible_Deferred_Completion
- (Prev_Id => Prev,
- Prev_Obj_Def => Object_Definition (Parent (Prev)),
- Curr_Obj_Def => Obj_Def);
+ begin
+ D := First_Discriminant (T);
+ New_D := First (Discriminant_Specifications (N));
+ while Present (D) loop
+ Prev_D := Current_Entity (D);
+ Set_Current_Entity (D);
+ Set_Is_Immediately_Visible (D);
+ Set_Homonym (D, Prev_D);
- Set_Full_View (Prev, Id);
- Set_Is_Public (Id, Is_Public (Prev));
- Set_Is_Internal (Id);
- Append_Entity (Id, Current_Scope);
+ -- Handle the case where there is an untagged partial view and
+ -- the full view is tagged: must disallow discriminants with
+ -- defaults, unless compiling for Ada 2012, which allows a
+ -- limited tagged type to have defaulted discriminants (see
+ -- AI05-0214). However, suppress error here if it was already
+ -- reported on the default expression of the partial view.
- -- Check ALIASED present if present before (RM 7.4(7))
+ if Is_Tagged_Type (T)
+ and then Present (Expression (Parent (D)))
+ and then (not Is_Limited_Type (Current_Scope)
+ or else Ada_Version < Ada_2012)
+ and then not Error_Posted (Expression (Parent (D)))
+ then
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_N
+ ("discriminants of nonlimited tagged type cannot have "
+ & "defaults",
+ Expression (New_D));
+ else
+ Error_Msg_N
+ ("discriminants of tagged type cannot have defaults",
+ Expression (New_D));
+ end if;
+ end if;
- if 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;
-
- -- Check that placement is in private part and that the incomplete
- -- declaration appeared in the visible part.
+ -- Ada 2005 (AI-230): Access discriminant allowed in
+ -- non-limited record types.
- 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);
+ if Ada_Version < Ada_2005 then
- elsif Ekind (Current_Scope) = E_Package
- and then
- List_Containing (Parent (Prev)) /=
- Visible_Declarations (Package_Specification (Current_Scope))
- then
- Error_Msg_N
- ("deferred constant must be declared in visible part",
- Parent (Prev));
- end if;
+ -- This restriction gets applied to the full type here. It
+ -- has already been applied earlier to the partial view.
- if Is_Access_Type (T)
- and then Nkind (Expression (N)) = N_Allocator
- then
- Check_Recursive_Declaration (Designated_Type (T));
- end if;
+ Check_Access_Discriminant_Requires_Limited (Parent (D), N);
+ end if;
- -- A deferred constant is a visible entity. If type has invariants,
- -- verify that the initial value satisfies them.
+ Next_Discriminant (D);
+ Next (New_D);
+ end loop;
+ end;
- if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then
- Insert_After (N,
- Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N))));
- end if;
+ elsif Present (Discriminant_Specifications (N)) then
+ Process_Discriminants (N, Prev);
end if;
- end Constant_Redeclaration;
+ end Check_Or_Process_Discriminants;
----------------------
- -- Constrain_Access --
+ -- Check_Real_Bound --
----------------------
- procedure Constrain_Access
- (Def_Id : in out Entity_Id;
- S : Node_Id;
+ 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
+ Flag_Non_Static_Expr
+ ("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;
+
+ ------------------------------
+ -- Complete_Private_Subtype --
+ ------------------------------
+
+ procedure Complete_Private_Subtype
+ (Priv : Entity_Id;
+ Full : Entity_Id;
+ Full_Base : Entity_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;
+ Save_Next_Entity : Entity_Id;
+ Save_Homonym : Entity_Id;
begin
- if Is_Array_Type (Desig_Type) then
- Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
+ -- Set semantic attributes for (implicit) private subtype completion.
+ -- If the full type has no discriminants, then it is a copy of the
+ -- full view of the base. Otherwise, it is a subtype of the base with
+ -- a possible discriminant constraint. Save and restore the original
+ -- Next_Entity field of full to ensure that the calls to Copy_Node do
+ -- not corrupt the entity chain.
+
+ -- Note that the type of the full view is the same entity as the type
+ -- of the partial view. In this fashion, the subtype has access to the
+ -- correct view of the parent.
- elsif (Is_Record_Type (Desig_Type)
- or else Is_Incomplete_Or_Private_Type (Desig_Type))
- and then not Is_Constrained (Desig_Type)
- then
- -- ??? The following code is a temporary bypass to ignore a
- -- discriminant constraint on access type if it is constraining
- -- the current record. Avoid creating the implicit subtype of the
- -- record we are currently compiling since right now, we cannot
- -- handle these. For now, just return the access type itself.
+ Save_Next_Entity := Next_Entity (Full);
+ Save_Homonym := Homonym (Priv);
- if Desig_Type = Current_Scope
- and then No (Def_Id)
- then
- Set_Ekind (Desig_Subtype, E_Record_Subtype);
- Def_Id := Entity (Subtype_Mark (S));
+ 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);
- -- This call added to ensure that the constraint is analyzed
- -- (needed for a B test). Note that we still return early from
- -- this procedure to avoid recursive processing. ???
+ Set_Has_Discriminants
+ (Full, Has_Discriminants (Full_Base));
+ Set_Has_Unknown_Discriminants
+ (Full, Has_Unknown_Discriminants (Full_Base));
+ Set_First_Entity (Full, First_Entity (Full_Base));
+ Set_Last_Entity (Full, Last_Entity (Full_Base));
- Constrain_Discriminated_Type
- (Desig_Subtype, S, Related_Nod, For_Access => True);
- return;
- end if;
+ -- If the underlying base type is constrained, we know that the
+ -- full view of the subtype is constrained as well (the converse
+ -- is not necessarily true).
- -- 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).
+ if Is_Constrained (Full_Base) then
+ Set_Is_Constrained (Full);
+ end if;
- -- Rule updated for Ada 2005: The private type is said to have
- -- a constrained partial view, given that objects of the type
- -- can be declared. Furthermore, the rule applies to all access
- -- types, unlike the rule concerning default discriminants (see
- -- RM 3.7.1(7/3))
+ when others =>
+ Copy_Node (Full_Base, Full);
- if (Ekind (T) = E_General_Access_Type
- or else Ada_Version >= Ada_2005)
- and then Has_Private_Declaration (Desig_Type)
- and then In_Open_Scopes (Scope (Desig_Type))
- and then Has_Discriminants (Desig_Type)
- then
- declare
- Pack : constant Node_Id :=
- Unit_Declaration_Node (Scope (Desig_Type));
- Decls : List_Id;
- Decl : Node_Id;
+ Set_Chars (Full, Chars (Priv));
+ Conditional_Delay (Full, Priv);
+ Set_Sloc (Full, Sloc (Priv));
+ end case;
- 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))
+ Set_Next_Entity (Full, Save_Next_Entity);
+ Set_Homonym (Full, Save_Homonym);
+ Set_Associated_Node_For_Itype (Full, Related_Nod);
- or else
- (Nkind (Decl) = N_Full_Type_Declaration
- and then
- Chars (Defining_Identifier (Decl)) =
- Chars (Desig_Type)
- and then Is_Derived_Type (Desig_Type)
- and then
- Has_Private_Declaration (Etype (Desig_Type)))
- then
- if No (Discriminant_Specifications (Decl)) then
- Error_Msg_N
- ("cannot constrain access type if designated " &
- "type has constrained partial view", S);
- end if;
+ -- Set common attributes for all subtypes: kind, convention, etc.
- exit;
- end if;
+ Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
+ Set_Convention (Full, Convention (Full_Base));
- Next (Decl);
- end loop;
- end if;
- end;
- end if;
+ -- The Etype of the full view is inconsistent. Gigi needs to see the
+ -- structural full view, which is what the current scheme gives: the
+ -- Etype of the full view is the etype of the full base. However, if the
+ -- full base is a derived type, the full view then looks like a subtype
+ -- of the parent, not a subtype of the full base. If instead we write:
- Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
- For_Access => True);
+ -- Set_Etype (Full, Full_Base);
- 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, ' ');
+ -- then we get inconsistencies in the front-end (confusion between
+ -- views). Several outstanding bugs are related to this ???
- else
- Error_Msg_N ("invalid constraint on access type", S);
- Desig_Subtype := Desig_Type; -- Ignore invalid constraint.
- Constraint_OK := False;
- end if;
+ 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 No (Def_Id) then
- Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
- else
- Set_Ekind (Def_Id, E_Access_Subtype);
- end if;
+ -- A subtype of a private-type-without-discriminants, whose full-view
+ -- has discriminants with default expressions, is not constrained.
- if Constraint_OK then
- Set_Etype (Def_Id, Base_Type (T));
+ if not Has_Discriminants (Priv) then
+ Set_Is_Constrained (Full, Is_Constrained (Full_Base));
- if Is_Private_Type (Desig_Type) then
- Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod);
+ if Has_Discriminants (Full_Base) then
+ Set_Discriminant_Constraint
+ (Full, Discriminant_Constraint (Full_Base));
+
+ -- The partial view may have been indefinite, the full view
+ -- might not be.
+
+ Set_Has_Unknown_Discriminants
+ (Full, Has_Unknown_Discriminants (Full_Base));
end if;
- 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));
+ Set_First_Rep_Item (Full, First_Rep_Item (Full_Base));
+ Set_Depends_On_Private (Full, Has_Private_Component (Full));
- Conditional_Delay (Def_Id, T);
+ -- Freeze the private subtype entity if its parent is delayed, and not
+ -- already frozen. We skip this processing if the type is an anonymous
+ -- subtype of a record component, or is the corresponding record of a
+ -- protected type, since these are processed when the enclosing type
+ -- is frozen.
- -- AI-363 : Subtypes of general access types whose designated types have
- -- default discriminants are disallowed. In instances, the rule has to
- -- be checked against the actual, of which T is the subtype. In a
- -- generic body, the rule is checked assuming that the actual type has
- -- defaulted discriminants.
+ if not Is_Type (Scope (Full)) then
+ Set_Has_Delayed_Freeze (Full,
+ Has_Delayed_Freeze (Full_Base)
+ and then (not Is_Frozen (Full_Base)));
+ end if;
- if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then
- if Ekind (Base_Type (T)) = E_General_Access_Type
- and then Has_Defaulted_Discriminants (Desig_Type)
- then
- if Ada_Version < Ada_2005 then
- Error_Msg_N
- ("access subtype of general access type would not " &
- "be allowed in Ada 2005?y?", S);
- else
- Error_Msg_N
- ("access subtype of general access type not allowed", S);
- end if;
-
- Error_Msg_N ("\discriminants have defaults", S);
+ Set_Freeze_Node (Full, Empty);
+ Set_Is_Frozen (Full, False);
+ Set_Full_View (Priv, Full);
- elsif Is_Access_Type (T)
- and then Is_Generic_Type (Desig_Type)
- and then Has_Discriminants (Desig_Type)
- and then In_Package_Body (Current_Scope)
- then
- if Ada_Version < Ada_2005 then
- Error_Msg_N
- ("access subtype would not be allowed in generic body " &
- "in Ada 2005?y?", S);
- else
- Error_Msg_N
- ("access subtype not allowed in generic body", S);
- end if;
+ if Has_Discriminants (Full) then
+ Set_Stored_Constraint_From_Discriminant_Constraint (Full);
+ Set_Stored_Constraint (Priv, Stored_Constraint (Full));
- Error_Msg_N
- ("\designated type is a discriminated formal", S);
+ if Has_Unknown_Discriminants (Full) then
+ Set_Discriminant_Constraint (Full, No_Elist);
end if;
end if;
- end Constrain_Access;
-
- ---------------------
- -- Constrain_Array --
- ---------------------
-
- procedure Constrain_Array
- (Def_Id : in out Entity_Id;
- SI : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id;
- Suffix : Character)
- is
- C : constant Node_Id := Constraint (SI);
- Number_Of_Constraints : Nat := 0;
- Index : Node_Id;
- S, T : Entity_Id;
- Constraint_OK : Boolean := True;
- begin
- T := Entity (Subtype_Mark (SI));
+ if Ekind (Full_Base) = E_Record_Type
+ and then Has_Discriminants (Full_Base)
+ and then Has_Discriminants (Priv) -- might not, if errors
+ and then not Has_Unknown_Discriminants (Priv)
+ and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
+ then
+ Create_Constrained_Components
+ (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
- if Is_Access_Type (T) then
- T := Designated_Type (T);
- end if;
+ -- If the full base is itself derived from private, build a congruent
+ -- subtype of its underlying type, for use by the back end. For a
+ -- constrained record component, the declaration cannot be placed on
+ -- the component list, but it must nevertheless be built an analyzed, to
+ -- supply enough information for Gigi to compute the size of component.
- -- If an index constraint follows a subtype mark in a subtype indication
- -- then the type or subtype denoted by the subtype mark must not already
- -- impose an index constraint. The subtype mark must denote either an
- -- unconstrained array type or an access type whose designated type
- -- is such an array type... (RM 3.6.1)
+ elsif Ekind (Full_Base) in Private_Kind
+ and then Is_Derived_Type (Full_Base)
+ and then Has_Discriminants (Full_Base)
+ and then (Ekind (Current_Scope) /= E_Record_Subtype)
+ then
+ if not Is_Itype (Priv)
+ and then
+ Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
+ then
+ Build_Underlying_Full_View
+ (Parent (Priv), Full, Etype (Full_Base));
- if Is_Constrained (T) then
- Error_Msg_N ("array type is already constrained", Subtype_Mark (SI));
- Constraint_OK := False;
+ elsif Nkind (Related_Nod) = N_Component_Declaration then
+ Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
+ end if;
- else
- S := First (Constraints (C));
- while Present (S) loop
- Number_Of_Constraints := Number_Of_Constraints + 1;
- Next (S);
- end loop;
+ elsif Is_Record_Type (Full_Base) then
- -- In either case, the index constraint must provide a discrete
- -- range for each index of the array type and the type of each
- -- discrete range must be the same as that of the corresponding
- -- index. (RM 3.6.1)
+ -- Show Full is simply a renaming of Full_Base
- if Number_Of_Constraints /= Number_Dimensions (T) then
- Error_Msg_NE ("incorrect number of index constraints for }", C, T);
- Constraint_OK := False;
+ Set_Cloned_Subtype (Full, Full_Base);
+ end if;
- else
- S := First (Constraints (C));
- Index := First_Index (T);
- Analyze (Index);
+ -- It is unsafe to share the bounds of a scalar type, because the Itype
+ -- is elaborated on demand, and if a bound is non-static then different
+ -- orders of elaboration in different units will lead to different
+ -- external symbols.
- -- Apply constraints to each index type
+ if Is_Scalar_Type (Full_Base) then
+ Set_Scalar_Range (Full,
+ Make_Range (Sloc (Related_Nod),
+ Low_Bound =>
+ Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)),
+ High_Bound =>
+ Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base))));
- for J in 1 .. Number_Of_Constraints loop
- Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
- Next (Index);
- Next (S);
- end loop;
+ -- This completion inherits the bounds of the full parent, but if
+ -- the parent is an unconstrained floating point type, so is the
+ -- completion.
+ if Is_Floating_Point_Type (Full_Base) then
+ Set_Includes_Infinities
+ (Scalar_Range (Full), Has_Infinities (Full_Base));
end if;
end if;
- if No (Def_Id) then
- Def_Id :=
- Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
- Set_Parent (Def_Id, Related_Nod);
+ -- ??? It seems that a lot of fields are missing that should be copied
+ -- from Full_Base to Full. Here are some that are introduced in a
+ -- non-disruptive way but a cleanup is necessary.
- else
- Set_Ekind (Def_Id, E_Array_Subtype);
- end if;
+ if Is_Tagged_Type (Full_Base) then
+ Set_Is_Tagged_Type (Full);
+ Set_Direct_Primitive_Operations
+ (Full, Direct_Primitive_Operations (Full_Base));
+ Set_No_Tagged_Streams_Pragma
+ (Full, No_Tagged_Streams_Pragma (Full_Base));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
- Set_Etype (Def_Id, Base_Type (T));
+ -- Inherit class_wide type of full_base in case the partial view was
+ -- not tagged. Otherwise it has already been created when the private
+ -- subtype was analyzed.
- if Constraint_OK then
- Set_First_Index (Def_Id, First (Constraints (C)));
- else
- Set_First_Index (Def_Id, First_Index (T));
- end if;
+ if No (Class_Wide_Type (Full)) then
+ Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base));
+ 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));
+ -- If this is a subtype of a protected or task type, constrain its
+ -- corresponding record, unless this is a subtype without constraints,
+ -- i.e. a simple renaming as with an actual subtype in an instance.
- Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
- Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
+ elsif Is_Concurrent_Type (Full_Base) then
+ if Has_Discriminants (Full)
+ and then Present (Corresponding_Record_Type (Full_Base))
+ and then
+ not Is_Empty_Elmt_List (Discriminant_Constraint (Full))
+ then
+ Set_Corresponding_Record_Type (Full,
+ Constrain_Corresponding_Record
+ (Full, Corresponding_Record_Type (Full_Base), Related_Nod));
- -- A subtype does not inherit the Packed_Array_Impl_Type of is parent.
- -- We need to initialize the attribute because if Def_Id is previously
- -- analyzed through a limited_with clause, it will have the attributes
- -- of an incomplete type, one of which is an Elist that overlaps the
- -- Packed_Array_Impl_Type field.
+ else
+ Set_Corresponding_Record_Type (Full,
+ Corresponding_Record_Type (Full_Base));
+ end if;
+ end if;
- Set_Packed_Array_Impl_Type (Def_Id, Empty);
+ -- Link rep item chain, and also setting of Has_Predicates from private
+ -- subtype to full subtype, since we will need these on the full subtype
+ -- to create the predicate function. Note that the full subtype may
+ -- already have rep items, inherited from the full view of the base
+ -- type, so we must be sure not to overwrite these entries.
- -- Build a freeze node if parent still needs one. Also make sure that
- -- the Depends_On_Private status is set because the subtype will need
- -- reprocessing at the time the base type does, and also we must set a
- -- conditional delay.
+ declare
+ Append : Boolean;
+ Item : Node_Id;
+ Next_Item : Node_Id;
- Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
- Conditional_Delay (Def_Id, T);
- end Constrain_Array;
+ begin
+ Item := First_Rep_Item (Full);
- ------------------------------
- -- Constrain_Component_Type --
- ------------------------------
+ -- If no existing rep items on full type, we can just link directly
+ -- to the list of items on the private type, if any exist.. Same if
+ -- the rep items are only those inherited from the base
- function Constrain_Component_Type
- (Comp : Entity_Id;
- Constrained_Typ : Entity_Id;
- Related_Node : Node_Id;
- Typ : Entity_Id;
- Constraints : Elist_Id) return Entity_Id
- is
- Loc : constant Source_Ptr := Sloc (Constrained_Typ);
- Compon_Type : constant Entity_Id := Etype (Comp);
+ if (No (Item)
+ or else Nkind (Item) /= N_Aspect_Specification
+ or else Entity (Item) = Full_Base)
+ and then Present (First_Rep_Item (Priv))
+ then
+ Set_First_Rep_Item (Full, First_Rep_Item (Priv));
- function Build_Constrained_Array_Type
- (Old_Type : Entity_Id) return Entity_Id;
- -- If Old_Type is an array type, one of whose indexes is constrained
- -- by a discriminant, build an Itype whose constraint replaces the
- -- discriminant with its value in the constraint.
+ -- Otherwise, search to the end of items currently linked to the full
+ -- subtype and append the private items to the end. However, if Priv
+ -- and Full already have the same list of rep items, then the append
+ -- is not done, as that would create a circularity.
- function Build_Constrained_Discriminated_Type
- (Old_Type : Entity_Id) return Entity_Id;
- -- Ditto for record components
+ elsif Item /= First_Rep_Item (Priv) then
+ Append := True;
+ loop
+ Next_Item := Next_Rep_Item (Item);
+ exit when No (Next_Item);
+ Item := Next_Item;
- function Build_Constrained_Access_Type
- (Old_Type : Entity_Id) return Entity_Id;
- -- Ditto for access types. Makes use of previous two functions, to
- -- constrain designated type.
+ -- If the private view has aspect specifications, the full view
+ -- inherits them. Since these aspects may already have been
+ -- attached to the full view during derivation, do not append
+ -- them if already present.
- function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
- -- T is an array or discriminated type, C is a list of constraints
- -- that apply to T. This routine builds the constrained subtype.
+ if Item = First_Rep_Item (Priv) then
+ Append := False;
+ exit;
+ end if;
+ end loop;
- function Is_Discriminant (Expr : Node_Id) return Boolean;
- -- Returns True if Expr is a discriminant
+ -- And link the private type items at the end of the chain
- function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
- -- Find the value of discriminant Discrim in Constraint
+ if Append then
+ Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
+ end if;
+ end if;
+ end;
- -----------------------------------
- -- Build_Constrained_Access_Type --
- -----------------------------------
+ -- Make sure Has_Predicates is set on full type if it is set on the
+ -- private type. Note that it may already be set on the full type and
+ -- if so, we don't want to unset it. Similarly, propagate information
+ -- about delayed aspects, because the corresponding pragmas must be
+ -- analyzed when one of the views is frozen. This last step is needed
+ -- in particular when the full type is a scalar type for which an
+ -- anonymous base type is constructed.
- 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;
+ if Has_Predicates (Priv) then
+ Set_Has_Predicates (Full);
+ end if;
- begin
- -- if the original access type was not embedded in the enclosing
- -- type definition, there is no need to produce a new access
- -- subtype. In fact every access type with an explicit constraint
- -- generates an itype whose scope is the enclosing record.
+ if Has_Delayed_Aspects (Priv) then
+ Set_Has_Delayed_Aspects (Full);
+ end if;
+ end Complete_Private_Subtype;
- if not Is_Type (Scope (Old_Type)) then
- return Old_Type;
+ ----------------------------
+ -- Constant_Redeclaration --
+ ----------------------------
- elsif Is_Array_Type (Desig_Type) then
- Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
+ 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;
- elsif Has_Discriminants (Desig_Type) then
+ procedure Check_Possible_Deferred_Completion
+ (Prev_Id : Entity_Id;
+ Prev_Obj_Def : Node_Id;
+ Curr_Obj_Def : Node_Id);
+ -- Determine whether the two object definitions describe the partial
+ -- and the full view of a constrained deferred constant. Generate
+ -- a subtype for the full view and verify that it statically matches
+ -- the subtype of the partial view.
- -- This may be an access type to an enclosing record type for
- -- which we are constructing the constrained components. Return
- -- the enclosing record subtype. This is not always correct,
- -- but avoids infinite recursion. ???
+ 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.
- Desig_Subtype := Any_Type;
+ ----------------------------------------
+ -- Check_Possible_Deferred_Completion --
+ ----------------------------------------
- for J in reverse 0 .. Scope_Stack.Last loop
- Scop := Scope_Stack.Table (J).Entity;
+ procedure Check_Possible_Deferred_Completion
+ (Prev_Id : Entity_Id;
+ Prev_Obj_Def : Node_Id;
+ Curr_Obj_Def : Node_Id)
+ is
+ begin
+ if Nkind (Prev_Obj_Def) = N_Subtype_Indication
+ and then Present (Constraint (Prev_Obj_Def))
+ and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
+ and then Present (Constraint (Curr_Obj_Def))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
+ Decl : constant Node_Id :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication =>
+ Relocate_Node (Curr_Obj_Def));
- if Is_Type (Scop)
- and then Base_Type (Scop) = Base_Type (Desig_Type)
- then
- Desig_Subtype := Scop;
- end if;
+ begin
+ Insert_Before_And_Analyze (N, Decl);
+ Set_Etype (Id, Def_Id);
- exit when not Is_Type (Scop);
- end loop;
+ if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
+ Error_Msg_Sloc := Sloc (Prev_Id);
+ Error_Msg_N ("subtype does not statically match deferred "
+ & "declaration #", N);
+ end if;
+ end;
+ end if;
+ end Check_Possible_Deferred_Completion;
- if Desig_Subtype = Any_Type then
- Desig_Subtype :=
- Build_Constrained_Discriminated_Type (Desig_Type);
- end if;
+ ---------------------------------
+ -- Check_Recursive_Declaration --
+ ---------------------------------
- else
- return Old_Type;
- end if;
+ procedure Check_Recursive_Declaration (Typ : Entity_Id) is
+ Comp : Entity_Id;
- if Desig_Subtype /= Desig_Type then
+ 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;
- -- The Related_Node better be here or else we won't be able
- -- to attach new itypes to a node in the tree.
+ elsif Is_Record_Type (Etype (Comp)) then
+ Check_Recursive_Declaration (Etype (Comp));
+ end if;
+ end if;
- pragma Assert (Present (Related_Node));
+ Next_Component (Comp);
+ end loop;
+ end if;
+ end Check_Recursive_Declaration;
- Itype := Create_Itype (E_Access_Subtype, Related_Node);
+ -- Start of processing for Constant_Redeclaration
- 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));
+ begin
+ if Nkind (Parent (Prev)) = N_Object_Declaration then
+ if Nkind (Object_Definition
+ (Parent (Prev))) = N_Subtype_Indication
+ then
+ -- Find type of new declaration. The constraints of the two
+ -- views must match statically, but there is no point in
+ -- creating an itype for the full view.
- -- The new itype needs freezing when it depends on a not frozen
- -- type and the enclosing subtype needs freezing.
+ if Nkind (Obj_Def) = N_Subtype_Indication then
+ Find_Type (Subtype_Mark (Obj_Def));
+ New_T := Entity (Subtype_Mark (Obj_Def));
- if Has_Delayed_Freeze (Constrained_Typ)
- and then not Is_Frozen (Constrained_Typ)
- then
- Conditional_Delay (Itype, Base_Type (Old_Type));
+ else
+ Find_Type (Obj_Def);
+ New_T := Entity (Obj_Def);
end if;
- return Itype;
+ T := Etype (Prev);
else
- return Old_Type;
- end if;
- end Build_Constrained_Access_Type;
-
- ----------------------------------
- -- Build_Constrained_Array_Type --
- ----------------------------------
+ -- The full view may impose a constraint, even if the partial
+ -- view does not, so construct the subtype.
- 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;
+ New_T := Find_Type_Of_Object (Obj_Def, N);
+ T := New_T;
+ end if;
- Need_To_Create_Itype : Boolean := False;
+ else
+ -- Current declaration is illegal, diagnosed below in Enter_Name
- begin
- Old_Index := First_Index (Old_Type);
- while Present (Old_Index) loop
- Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
+ T := Empty;
+ New_T := Any_Type;
+ end if;
- if Is_Discriminant (Lo_Expr)
- or else Is_Discriminant (Hi_Expr)
- then
- Need_To_Create_Itype := True;
- end if;
+ -- If previous full declaration or a renaming declaration exists, or if
+ -- a homograph is present, let Enter_Name handle it, either with an
+ -- error or with the removal of an overridden implicit subprogram.
+ -- The previous one is a full declaration if it has an expression
+ -- (which in the case of an aggregate is indicated by the Init flag).
- Next_Index (Old_Index);
- end loop;
+ if Ekind (Prev) /= E_Constant
+ or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration
+ or else Present (Expression (Parent (Prev)))
+ or else Has_Init_Expression (Parent (Prev))
+ or else Present (Full_View (Prev))
+ then
+ Enter_Name (Id);
- if Need_To_Create_Itype then
- Constr_List := New_List;
+ -- Verify that types of both declarations match, or else that both types
+ -- are anonymous access types whose designated subtypes statically match
+ -- (as allowed in Ada 2005 by AI-385).
- Old_Index := First_Index (Old_Type);
- while Present (Old_Index) loop
- Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
+ elsif Base_Type (Etype (Prev)) /= Base_Type (New_T)
+ and then
+ (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type
+ or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type
+ or else Is_Access_Constant (Etype (New_T)) /=
+ Is_Access_Constant (Etype (Prev))
+ or else Can_Never_Be_Null (Etype (New_T)) /=
+ Can_Never_Be_Null (Etype (Prev))
+ or else Null_Exclusion_Present (Parent (Prev)) /=
+ Null_Exclusion_Present (Parent (Id))
+ or else not Subtypes_Statically_Match
+ (Designated_Type (Etype (Prev)),
+ Designated_Type (Etype (New_T))))
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N ("type does not match declaration#", N);
+ Set_Full_View (Prev, Id);
+ Set_Etype (Id, Any_Type);
- if Is_Discriminant (Lo_Expr) then
- Lo_Expr := Get_Discr_Value (Lo_Expr);
- end if;
+ -- A deferred constant whose type is an anonymous array is always
+ -- illegal (unless imported). A detailed error message might be
+ -- helpful for Ada beginners.
- if Is_Discriminant (Hi_Expr) then
- Hi_Expr := Get_Discr_Value (Hi_Expr);
- end if;
+ if Nkind (Object_Definition (Parent (Prev)))
+ = N_Constrained_Array_Definition
+ and then Nkind (Object_Definition (N))
+ = N_Constrained_Array_Definition
+ then
+ Error_Msg_N ("\each anonymous array is a distinct type", N);
+ Error_Msg_N ("a deferred constant must have a named type",
+ Object_Definition (Parent (Prev)));
+ end if;
- Range_Node :=
- Make_Range
- (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
+ elsif
+ Null_Exclusion_Present (Parent (Prev))
+ and then not Null_Exclusion_Present (N)
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N ("null-exclusion does not match declaration#", N);
+ Set_Full_View (Prev, Id);
+ Set_Etype (Id, Any_Type);
- Append (Range_Node, To => Constr_List);
+ -- If so, process the full constant declaration
- Next_Index (Old_Index);
- end loop;
+ else
+ -- RM 7.4 (6): If the subtype defined by the subtype_indication in
+ -- the deferred declaration is constrained, then the subtype defined
+ -- by the subtype_indication in the full declaration shall match it
+ -- statically.
- return Build_Subtype (Old_Type, Constr_List);
+ Check_Possible_Deferred_Completion
+ (Prev_Id => Prev,
+ Prev_Obj_Def => Object_Definition (Parent (Prev)),
+ Curr_Obj_Def => Obj_Def);
- else
- return Old_Type;
+ Set_Full_View (Prev, Id);
+ Set_Is_Public (Id, Is_Public (Prev));
+ Set_Is_Internal (Id);
+ Append_Entity (Id, Current_Scope);
+
+ -- Check ALIASED present if present before (RM 7.4(7))
+
+ if Is_Aliased (Prev)
+ and then not Aliased_Present (N)
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N ("ALIASED required (see declaration #)", N);
end if;
- end Build_Constrained_Array_Type;
- ------------------------------------------
- -- Build_Constrained_Discriminated_Type --
- ------------------------------------------
+ -- Check that placement is in private part and that the incomplete
+ -- declaration appeared in the visible part.
- function Build_Constrained_Discriminated_Type
- (Old_Type : Entity_Id) return Entity_Id
- is
- Expr : Node_Id;
- Constr_List : List_Id;
- Old_Constraint : Elmt_Id;
+ 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);
- Need_To_Create_Itype : Boolean := False;
+ elsif Ekind (Current_Scope) = E_Package
+ and then
+ List_Containing (Parent (Prev)) /=
+ Visible_Declarations (Package_Specification (Current_Scope))
+ then
+ Error_Msg_N
+ ("deferred constant must be declared in visible part",
+ Parent (Prev));
+ end if;
- begin
- Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
- while Present (Old_Constraint) loop
- Expr := Node (Old_Constraint);
+ if Is_Access_Type (T)
+ and then Nkind (Expression (N)) = N_Allocator
+ then
+ Check_Recursive_Declaration (Designated_Type (T));
+ end if;
- if Is_Discriminant (Expr) then
- Need_To_Create_Itype := True;
- end if;
+ -- A deferred constant is a visible entity. If type has invariants,
+ -- verify that the initial value satisfies them.
- Next_Elmt (Old_Constraint);
- end loop;
+ if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then
+ Insert_After (N,
+ Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N))));
+ end if;
+ end if;
+ end Constant_Redeclaration;
- if Need_To_Create_Itype then
- Constr_List := New_List;
+ ----------------------
+ -- Constrain_Access --
+ ----------------------
- Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
- while Present (Old_Constraint) loop
- Expr := Node (Old_Constraint);
+ 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;
- if Is_Discriminant (Expr) then
- Expr := Get_Discr_Value (Expr);
- end if;
+ begin
+ if Is_Array_Type (Desig_Type) then
+ Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P');
- Append (New_Copy_Tree (Expr), To => Constr_List);
+ elsif (Is_Record_Type (Desig_Type)
+ or else Is_Incomplete_Or_Private_Type (Desig_Type))
+ and then not Is_Constrained (Desig_Type)
+ then
+ -- ??? The following code is a temporary bypass to ignore a
+ -- discriminant constraint on access type if it is constraining
+ -- the current record. Avoid creating the implicit subtype of the
+ -- record we are currently compiling since right now, we cannot
+ -- handle these. For now, just return the access type itself.
- Next_Elmt (Old_Constraint);
- end loop;
+ if Desig_Type = Current_Scope
+ and then No (Def_Id)
+ then
+ Set_Ekind (Desig_Subtype, E_Record_Subtype);
+ Def_Id := Entity (Subtype_Mark (S));
- return Build_Subtype (Old_Type, Constr_List);
+ -- This call added to ensure that the constraint is analyzed
+ -- (needed for a B test). Note that we still return early from
+ -- this procedure to avoid recursive processing. ???
- else
- return Old_Type;
+ Constrain_Discriminated_Type
+ (Desig_Subtype, S, Related_Nod, For_Access => True);
+ return;
end if;
- end Build_Constrained_Discriminated_Type;
- -------------------
- -- Build_Subtype --
- -------------------
+ -- Enforce rule that the constraint is illegal if there is an
+ -- unconstrained view of the designated type. This means that the
+ -- partial view (either a private type declaration or a derivation
+ -- from a private type) has no discriminants. (Defect Report
+ -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001).
- 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);
+ -- Rule updated for Ada 2005: The private type is said to have
+ -- a constrained partial view, given that objects of the type
+ -- can be declared. Furthermore, the rule applies to all access
+ -- types, unlike the rule concerning default discriminants (see
+ -- RM 3.7.1(7/3))
- begin
- -- The Related_Node better be here or else we won't be able to
- -- attach new itypes to a node in the tree.
+ if (Ekind (T) = E_General_Access_Type or else Ada_Version >= Ada_2005)
+ and then Has_Private_Declaration (Desig_Type)
+ and then In_Open_Scopes (Scope (Desig_Type))
+ and then Has_Discriminants (Desig_Type)
+ then
+ declare
+ Pack : constant Node_Id :=
+ Unit_Declaration_Node (Scope (Desig_Type));
+ Decls : List_Id;
+ Decl : Node_Id;
- pragma Assert (Present (Related_Node));
+ 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))
- -- If the view of the component's type is incomplete or private
- -- with unknown discriminants, then the constraint must be applied
- -- to the full type.
+ or else
+ (Nkind (Decl) = N_Full_Type_Declaration
+ and then
+ Chars (Defining_Identifier (Decl)) =
+ Chars (Desig_Type)
+ and then Is_Derived_Type (Desig_Type)
+ and then
+ Has_Private_Declaration (Etype (Desig_Type)))
+ then
+ if No (Discriminant_Specifications (Decl)) then
+ Error_Msg_N
+ ("cannot constrain access type if designated "
+ & "type has constrained partial view", S);
+ end if;
- if Has_Unknown_Discriminants (Btyp)
- and then Present (Underlying_Type (Btyp))
- then
- Btyp := Underlying_Type (Btyp);
+ exit;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+ end;
end if;
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
+ Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
+ For_Access => True);
- Def_Id := Create_Itype (Ekind (T), Related_Node);
+ elsif Is_Concurrent_Type (Desig_Type)
+ and then not Is_Constrained (Desig_Type)
+ then
+ Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
- Subtyp_Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Indication => Indic);
+ else
+ Error_Msg_N ("invalid constraint on access type", S);
- Set_Parent (Subtyp_Decl, Parent (Related_Node));
+ -- We simply ignore an invalid constraint
- -- Itypes must be analyzed with checks off (see package Itypes)
+ Desig_Subtype := Desig_Type;
+ Constraint_OK := False;
+ end if;
- Analyze (Subtyp_Decl, Suppress => All_Checks);
+ if No (Def_Id) then
+ Def_Id := Create_Itype (E_Access_Subtype, Related_Nod);
+ else
+ Set_Ekind (Def_Id, E_Access_Subtype);
+ end if;
- return Def_Id;
- end Build_Subtype;
+ if Constraint_OK then
+ Set_Etype (Def_Id, Base_Type (T));
- ---------------------
- -- Get_Discr_Value --
- ---------------------
+ 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;
- function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
- D : Entity_Id;
- E : Elmt_Id;
+ 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));
- begin
- -- The discriminant may be declared for the type, in which case we
- -- find it by iterating over the list of discriminants. If the
- -- discriminant is inherited from a parent type, it appears as the
- -- corresponding discriminant of the current type. This will be the
- -- case when constraining an inherited component whose constraint is
- -- given by a discriminant of the parent.
+ Conditional_Delay (Def_Id, T);
- D := First_Discriminant (Typ);
- E := First_Elmt (Constraints);
+ -- AI-363 : Subtypes of general access types whose designated types have
+ -- default discriminants are disallowed. In instances, the rule has to
+ -- be checked against the actual, of which T is the subtype. In a
+ -- generic body, the rule is checked assuming that the actual type has
+ -- defaulted discriminants.
- while Present (D) loop
- if D = Entity (Discrim)
- or else D = CR_Discriminant (Entity (Discrim))
- or else Corresponding_Discriminant (D) = Entity (Discrim)
- then
- return Node (E);
+ if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then
+ if Ekind (Base_Type (T)) = E_General_Access_Type
+ and then Has_Defaulted_Discriminants (Desig_Type)
+ then
+ if Ada_Version < Ada_2005 then
+ Error_Msg_N
+ ("access subtype of general access type would not " &
+ "be allowed in Ada 2005?y?", S);
+ else
+ Error_Msg_N
+ ("access subtype of general access type not allowed", S);
end if;
- Next_Discriminant (D);
- 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 stored_constraint, the list of
- -- discriminants of the parents, and the constraints.
-
- -- Previous code checked for the present of the Stored_Constraint
- -- list for the derived type, but did not use it at all. Should it
- -- be present when the component is a discriminated task type?
+ Error_Msg_N ("\discriminants have defaults", S);
- if Is_Derived_Type (Typ)
- and then Scope (Entity (Discrim)) = Etype (Typ)
+ elsif Is_Access_Type (T)
+ and then Is_Generic_Type (Desig_Type)
+ and then Has_Discriminants (Desig_Type)
+ and then In_Package_Body (Current_Scope)
then
- D := First_Discriminant (Etype (Typ));
- E := First_Elmt (Constraints);
- while Present (D) loop
- if D = Entity (Discrim) then
- return Node (E);
- end if;
+ if Ada_Version < Ada_2005 then
+ Error_Msg_N
+ ("access subtype would not be allowed in generic body "
+ & "in Ada 2005?y?", S);
+ else
+ Error_Msg_N
+ ("access subtype not allowed in generic body", S);
+ end if;
- Next_Discriminant (D);
- Next_Elmt (E);
- end loop;
+ Error_Msg_N
+ ("\designated type is a discriminated formal", S);
end if;
+ end if;
+ end Constrain_Access;
- -- Something is wrong if we did not find the value
+ ---------------------
+ -- Constrain_Array --
+ ---------------------
- raise Program_Error;
- end Get_Discr_Value;
+ 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;
- ---------------------
- -- Is_Discriminant --
- ---------------------
+ begin
+ T := Entity (Subtype_Mark (SI));
- function Is_Discriminant (Expr : Node_Id) return Boolean is
- Discrim_Scope : Entity_Id;
+ if Is_Access_Type (T) then
+ T := Designated_Type (T);
+ end if;
- begin
- if Denotes_Discriminant (Expr) then
- Discrim_Scope := Scope (Entity (Expr));
+ -- If an index constraint follows a subtype mark in a subtype indication
+ -- then the type or subtype denoted by the subtype mark must not already
+ -- impose an index constraint. The subtype mark must denote either an
+ -- unconstrained array type or an access type whose designated type
+ -- is such an array type... (RM 3.6.1)
- -- Either we have a reference to one of Typ's discriminants,
+ if Is_Constrained (T) then
+ Error_Msg_N ("array type is already constrained", Subtype_Mark (SI));
+ Constraint_OK := False;
- pragma Assert (Discrim_Scope = Typ
+ else
+ S := First (Constraints (C));
+ while Present (S) loop
+ Number_Of_Constraints := Number_Of_Constraints + 1;
+ Next (S);
+ end loop;
- -- or to the discriminants of the parent type, in the case
- -- of a derivation of a tagged type with variants.
+ -- In either case, the index constraint must provide a discrete
+ -- range for each index of the array type and the type of each
+ -- discrete range must be the same as that of the corresponding
+ -- index. (RM 3.6.1)
- or else Discrim_Scope = Etype (Typ)
- or else Full_View (Discrim_Scope) = Etype (Typ)
+ if Number_Of_Constraints /= Number_Dimensions (T) then
+ Error_Msg_NE ("incorrect number of index constraints for }", C, T);
+ Constraint_OK := False;
- -- or same as above for the case where the discriminants
- -- were declared in Typ's private view.
+ else
+ S := First (Constraints (C));
+ Index := First_Index (T);
+ Analyze (Index);
- or else (Is_Private_Type (Discrim_Scope)
- and then Chars (Discrim_Scope) = Chars (Typ))
+ -- Apply constraints to each index type
- -- or else we are deriving from the full view and the
- -- discriminant is declared in the private entity.
+ for J in 1 .. Number_Of_Constraints loop
+ Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J);
+ Next (Index);
+ Next (S);
+ end loop;
- or else (Is_Private_Type (Typ)
- and then Chars (Discrim_Scope) = Chars (Typ))
+ end if;
+ end if;
- -- Or we are constrained the corresponding record of a
- -- synchronized type that completes a private declaration.
+ if No (Def_Id) then
+ Def_Id :=
+ Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
+ Set_Parent (Def_Id, Related_Nod);
- or else (Is_Concurrent_Record_Type (Typ)
- and then
- Corresponding_Concurrent_Type (Typ) = Discrim_Scope)
+ else
+ Set_Ekind (Def_Id, E_Array_Subtype);
+ end if;
- -- or we have a class-wide type, in which case make sure the
- -- discriminant found belongs to the root type.
+ Set_Size_Info (Def_Id, (T));
+ Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Set_Etype (Def_Id, Base_Type (T));
- or else (Is_Class_Wide_Type (Typ)
- and then Etype (Typ) = Discrim_Scope));
+ if Constraint_OK then
+ Set_First_Index (Def_Id, First (Constraints (C)));
+ else
+ Set_First_Index (Def_Id, First_Index (T));
+ end if;
- return True;
- 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));
- -- In all other cases we have something wrong
+ Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
+ Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
- return False;
- end Is_Discriminant;
+ -- A subtype does not inherit the Packed_Array_Impl_Type of is parent.
+ -- We need to initialize the attribute because if Def_Id is previously
+ -- analyzed through a limited_with clause, it will have the attributes
+ -- of an incomplete type, one of which is an Elist that overlaps the
+ -- Packed_Array_Impl_Type field.
- -- Start of processing for Constrain_Component_Type
+ Set_Packed_Array_Impl_Type (Def_Id, Empty);
- begin
- if Nkind (Parent (Comp)) = N_Component_Declaration
- and then Comes_From_Source (Parent (Comp))
- and then Comes_From_Source
- (Subtype_Indication (Component_Definition (Parent (Comp))))
- and then
- Is_Entity_Name
- (Subtype_Indication (Component_Definition (Parent (Comp))))
- then
- return Compon_Type;
+ -- Build a freeze node if parent still needs one. Also make sure that
+ -- the Depends_On_Private status is set because the subtype will need
+ -- reprocessing at the time the base type does, and also we must set a
+ -- conditional delay.
- elsif Is_Array_Type (Compon_Type) then
- return Build_Constrained_Array_Type (Compon_Type);
+ Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
+ Conditional_Delay (Def_Id, T);
+ end Constrain_Array;
- elsif Has_Discriminants (Compon_Type) then
- return Build_Constrained_Discriminated_Type (Compon_Type);
+ ------------------------------
+ -- Constrain_Component_Type --
+ ------------------------------
- elsif Is_Access_Type (Compon_Type) then
- return Build_Constrained_Access_Type (Compon_Type);
+ function Constrain_Component_Type
+ (Comp : Entity_Id;
+ Constrained_Typ : Entity_Id;
+ Related_Node : Node_Id;
+ Typ : Entity_Id;
+ Constraints : Elist_Id) return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Constrained_Typ);
+ Compon_Type : constant Entity_Id := Etype (Comp);
- else
- return Compon_Type;
- end if;
- end Constrain_Component_Type;
+ function Build_Constrained_Array_Type
+ (Old_Type : Entity_Id) return Entity_Id;
+ -- If Old_Type is an array type, one of whose indexes is constrained
+ -- by a discriminant, build an Itype whose constraint replaces the
+ -- discriminant with its value in the constraint.
- --------------------------
- -- Constrain_Concurrent --
- --------------------------
+ function Build_Constrained_Discriminated_Type
+ (Old_Type : Entity_Id) return Entity_Id;
+ -- Ditto for record components
- -- For concurrent types, the associated record value type carries the same
- -- discriminants, so when we constrain a concurrent type, we must constrain
- -- the corresponding record type as well.
+ function Build_Constrained_Access_Type
+ (Old_Type : Entity_Id) return Entity_Id;
+ -- Ditto for access types. Makes use of previous two functions, to
+ -- constrain designated type.
- procedure Constrain_Concurrent
- (Def_Id : in out Entity_Id;
- SI : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id;
- Suffix : Character)
- is
- -- Retrieve Base_Type to ensure getting to the concurrent type in the
- -- case of a private subtype (needed when only doing semantic analysis).
+ function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
+ -- T is an array or discriminated type, C is a list of constraints
+ -- that apply to T. This routine builds the constrained subtype.
- T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI)));
- T_Val : Entity_Id;
+ function Is_Discriminant (Expr : Node_Id) return Boolean;
+ -- Returns True if Expr is a discriminant
- begin
- if Is_Access_Type (T_Ent) then
- T_Ent := Designated_Type (T_Ent);
- end if;
-
- T_Val := Corresponding_Record_Type (T_Ent);
-
- if Present (T_Val) then
+ function Get_Discr_Value (Discrim : Entity_Id) return Node_Id;
+ -- Find the value of discriminant Discrim in Constraint
- if No (Def_Id) then
- Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
- end if;
+ -----------------------------------
+ -- Build_Constrained_Access_Type --
+ -----------------------------------
- Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+ 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;
- 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));
+ begin
+ -- if the original access type was not embedded in the enclosing
+ -- type definition, there is no need to produce a new access
+ -- subtype. In fact every access type with an explicit constraint
+ -- generates an itype whose scope is the enclosing record.
- else
- -- If there is no associated record, expansion is disabled and this
- -- is a generic context. Create a subtype in any case, so that
- -- semantic analysis can proceed.
+ if not Is_Type (Scope (Old_Type)) then
+ return Old_Type;
- if No (Def_Id) then
- Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
- end if;
+ elsif Is_Array_Type (Desig_Type) then
+ Desig_Subtype := Build_Constrained_Array_Type (Desig_Type);
- Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
- end if;
- end Constrain_Concurrent;
+ elsif Has_Discriminants (Desig_Type) then
- ------------------------------------
- -- Constrain_Corresponding_Record --
- ------------------------------------
+ -- This may be an access type to an enclosing record type for
+ -- which we are constructing the constrained components. Return
+ -- the enclosing record subtype. This is not always correct,
+ -- but avoids infinite recursion. ???
- function Constrain_Corresponding_Record
- (Prot_Subt : Entity_Id;
- Corr_Rec : Entity_Id;
- Related_Nod : Node_Id) return Entity_Id
- is
- T_Sub : constant Entity_Id :=
- Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C');
+ Desig_Subtype := Any_Type;
- begin
- Set_Etype (T_Sub, Corr_Rec);
- Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
- Set_Is_Constrained (T_Sub, True);
- Set_First_Entity (T_Sub, First_Entity (Corr_Rec));
- Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec));
+ for J in reverse 0 .. Scope_Stack.Last loop
+ Scop := Scope_Stack.Table (J).Entity;
- if Has_Discriminants (Prot_Subt) then -- False only if errors.
- Set_Discriminant_Constraint
- (T_Sub, Discriminant_Constraint (Prot_Subt));
- Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub);
- Create_Constrained_Components
- (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub));
- end if;
+ if Is_Type (Scop)
+ and then Base_Type (Scop) = Base_Type (Desig_Type)
+ then
+ Desig_Subtype := Scop;
+ end if;
- Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub));
+ exit when not Is_Type (Scop);
+ end loop;
- if Ekind (Scope (Prot_Subt)) /= E_Record_Type then
- Conditional_Delay (T_Sub, Corr_Rec);
+ if Desig_Subtype = Any_Type then
+ Desig_Subtype :=
+ Build_Constrained_Discriminated_Type (Desig_Type);
+ end if;
- else
- -- This is a component subtype: it will be frozen in the context of
- -- the enclosing record's init_proc, so that discriminant references
- -- are resolved to discriminals. (Note: we used to skip freezing
- -- altogether in that case, which caused errors downstream for
- -- components of a bit packed array type).
+ else
+ return Old_Type;
+ end if;
- Set_Has_Delayed_Freeze (T_Sub);
- end if;
+ if Desig_Subtype /= Desig_Type then
- return T_Sub;
- end Constrain_Corresponding_Record;
+ -- The Related_Node better be here or else we won't be able
+ -- to attach new itypes to a node in the tree.
- -----------------------
- -- Constrain_Decimal --
- -----------------------
+ pragma Assert (Present (Related_Node));
- 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;
+ Itype := Create_Itype (E_Access_Subtype, Related_Node);
- begin
- Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype);
+ 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 Nkind (C) = N_Range_Constraint then
- Range_Expr := Range_Expression (C);
- Digits_Val := Digits_Value (T);
+ -- The new itype needs freezing when it depends on a not frozen
+ -- type and the enclosing subtype needs freezing.
- else
- pragma Assert (Nkind (C) = N_Digits_Constraint);
+ if Has_Delayed_Freeze (Constrained_Typ)
+ and then not Is_Frozen (Constrained_Typ)
+ then
+ Conditional_Delay (Itype, Base_Type (Old_Type));
+ end if;
- Check_SPARK_Restriction ("digits constraint is not allowed", S);
+ return Itype;
- Digits_Expr := Digits_Expression (C);
- Analyze_And_Resolve (Digits_Expr, Any_Integer);
+ else
+ return Old_Type;
+ end if;
+ end Build_Constrained_Access_Type;
- Check_Digits_Expression (Digits_Expr);
- Digits_Val := Expr_Value (Digits_Expr);
+ ----------------------------------
+ -- Build_Constrained_Array_Type --
+ ----------------------------------
- if Digits_Val > Digits_Value (T) then
- Error_Msg_N
- ("digits expression is incompatible with subtype", C);
- Digits_Val := Digits_Value (T);
- end if;
+ function 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;
- if Present (Range_Constraint (C)) then
- Range_Expr := Range_Expression (Range_Constraint (C));
- else
- Range_Expr := Empty;
- end if;
- end if;
+ Need_To_Create_Itype : Boolean := False;
- 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);
+ begin
+ Old_Index := First_Index (Old_Type);
+ while Present (Old_Index) loop
+ Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
- -- Manufacture range from given digits value if no range present
+ if Is_Discriminant (Lo_Expr)
+ or else
+ Is_Discriminant (Hi_Expr)
+ then
+ Need_To_Create_Itype := True;
+ end if;
- 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;
+ Next_Index (Old_Index);
+ end loop;
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T);
- Set_Discrete_RM_Size (Def_Id);
+ if Need_To_Create_Itype then
+ Constr_List := New_List;
- -- Unconditionally delay the freeze, since we cannot set size
- -- information in all cases correctly until the freeze point.
+ Old_Index := First_Index (Old_Type);
+ while Present (Old_Index) loop
+ Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr);
- Set_Has_Delayed_Freeze (Def_Id);
- end Constrain_Decimal;
+ if Is_Discriminant (Lo_Expr) then
+ Lo_Expr := Get_Discr_Value (Lo_Expr);
+ end if;
- ----------------------------------
- -- Constrain_Discriminated_Type --
- ----------------------------------
+ if Is_Discriminant (Hi_Expr) then
+ Hi_Expr := Get_Discr_Value (Hi_Expr);
+ end if;
- 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;
+ Range_Node :=
+ Make_Range
+ (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr));
- procedure Fixup_Bad_Constraint;
- -- This is called after finding a bad constraint, and after having
- -- posted an appropriate error message. The mission is to leave the
- -- entity T in as reasonable state as possible.
+ Append (Range_Node, To => Constr_List);
- --------------------------
- -- Fixup_Bad_Constraint --
- --------------------------
+ Next_Index (Old_Index);
+ end loop;
- procedure Fixup_Bad_Constraint is
- begin
- -- Set a reasonable Ekind for the entity. For an incomplete type,
- -- we can't do much, but for other types, we can set the proper
- -- corresponding subtype kind.
+ return Build_Subtype (Old_Type, Constr_List);
- if Ekind (T) = E_Incomplete_Type then
- Set_Ekind (Def_Id, Ekind (T));
else
- Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+ return Old_Type;
end if;
+ end Build_Constrained_Array_Type;
- -- Set Etype to the known type, to reduce chances of cascaded errors
-
- Set_Etype (Def_Id, E);
- Set_Error_Posted (Def_Id);
- end Fixup_Bad_Constraint;
+ ------------------------------------------
+ -- Build_Constrained_Discriminated_Type --
+ ------------------------------------------
- -- Start of processing for Constrain_Discriminated_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;
- begin
- C := Constraint (S);
+ Need_To_Create_Itype : Boolean := False;
- -- A discriminant constraint is only allowed in a subtype indication,
- -- after a subtype mark. This subtype mark must denote either a type
- -- with discriminants, or an access type whose designated type is a
- -- type with discriminants. A discriminant constraint specifies the
- -- values of these discriminants (RM 3.7.2(5)).
+ begin
+ Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
+ while Present (Old_Constraint) loop
+ Expr := Node (Old_Constraint);
- T := Base_Type (Entity (Subtype_Mark (S)));
+ if Is_Discriminant (Expr) then
+ Need_To_Create_Itype := True;
+ end if;
- if Is_Access_Type (T) then
- T := Designated_Type (T);
- end if;
+ Next_Elmt (Old_Constraint);
+ end loop;
- -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
- -- Avoid generating an error for access-to-incomplete subtypes.
+ if Need_To_Create_Itype then
+ Constr_List := New_List;
- if Ada_Version >= Ada_2005
- and then Ekind (T) = E_Incomplete_Type
- and then Nkind (Parent (S)) = N_Subtype_Declaration
- and then not Is_Itype (Def_Id)
- then
- -- A little sanity check, emit an error message if the type
- -- has discriminants to begin with. Type T may be a regular
- -- incomplete type or imported via a limited with clause.
+ Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type));
+ while Present (Old_Constraint) loop
+ Expr := Node (Old_Constraint);
- if Has_Discriminants (T)
- or else (From_Limited_With (T)
- and then Present (Non_Limited_View (T))
- and then Nkind (Parent (Non_Limited_View (T))) =
- N_Full_Type_Declaration
- and then Present (Discriminant_Specifications
- (Parent (Non_Limited_View (T)))))
- then
- Error_Msg_N
- ("(Ada 2005) incomplete subtype may not be constrained", C);
- else
- Error_Msg_N ("invalid constraint: type has no discriminant", C);
- end if;
+ if Is_Discriminant (Expr) then
+ Expr := Get_Discr_Value (Expr);
+ end if;
- Fixup_Bad_Constraint;
- return;
+ Append (New_Copy_Tree (Expr), To => Constr_List);
- -- Check that the type has visible discriminants. The type may be
- -- a private type with unknown discriminants whose full view has
- -- discriminants which are invisible.
+ Next_Elmt (Old_Constraint);
+ end loop;
- elsif not Has_Discriminants (T)
- or else
- (Has_Unknown_Discriminants (T)
- and then Is_Private_Type (T))
- then
- Error_Msg_N ("invalid constraint: type has no discriminant", C);
- Fixup_Bad_Constraint;
- return;
+ return Build_Subtype (Old_Type, Constr_List);
- 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;
+ else
+ return Old_Type;
+ end if;
+ end Build_Constrained_Discriminated_Type;
- -- T may be an unconstrained subtype (e.g. a generic actual).
- -- Constraint applies to the base type.
+ -------------------
+ -- Build_Subtype --
+ -------------------
- T := Base_Type (T);
+ 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);
- Elist := Build_Discriminant_Constraints (T, S);
+ begin
+ -- The Related_Node better be here or else we won't be able to
+ -- attach new itypes to a node in the tree.
- -- If the list returned was empty we had an error in building the
- -- discriminant constraint. We have also already signalled an error
- -- in the incomplete type case
+ pragma Assert (Present (Related_Node));
- if Is_Empty_Elmt_List (Elist) then
- Fixup_Bad_Constraint;
- return;
- end if;
+ -- If the view of the component's type is incomplete or private
+ -- with unknown discriminants, then the constraint must be applied
+ -- to the full type.
- Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
- end Constrain_Discriminated_Type;
+ if Has_Unknown_Discriminants (Btyp)
+ and then Present (Underlying_Type (Btyp))
+ then
+ Btyp := Underlying_Type (Btyp);
+ end if;
- ---------------------------
- -- Constrain_Enumeration --
- ---------------------------
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
+ Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
- 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);
+ Def_Id := Create_Itype (Ekind (T), Related_Node);
- begin
- Set_Ekind (Def_Id, E_Enumeration_Subtype);
+ Subtyp_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication => Indic);
- Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
+ Set_Parent (Subtyp_Decl, Parent (Related_Node));
- 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));
+ -- Itypes must be analyzed with checks off (see package Itypes)
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
+ Analyze (Subtyp_Decl, Suppress => All_Checks);
- Set_Discrete_RM_Size (Def_Id);
- end Constrain_Enumeration;
+ return Def_Id;
+ end Build_Subtype;
- ----------------------
- -- Constrain_Float --
- ----------------------
+ ---------------------
+ -- Get_Discr_Value --
+ ---------------------
- procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is
- T : constant Entity_Id := Entity (Subtype_Mark (S));
- C : Node_Id;
- D : Node_Id;
- Rais : Node_Id;
+ function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
+ D : Entity_Id;
+ E : Elmt_Id;
- begin
- Set_Ekind (Def_Id, E_Floating_Point_Subtype);
+ begin
+ -- The discriminant may be declared for the type, in which case we
+ -- find it by iterating over the list of discriminants. If the
+ -- discriminant is inherited from a parent type, it appears as the
+ -- corresponding discriminant of the current type. This will be the
+ -- case when constraining an inherited component whose constraint is
+ -- given by a discriminant of the parent.
- Set_Etype (Def_Id, Base_Type (T));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ D := First_Discriminant (Typ);
+ E := First_Elmt (Constraints);
- -- Process the constraint
+ while Present (D) loop
+ if D = Entity (Discrim)
+ or else D = CR_Discriminant (Entity (Discrim))
+ or else Corresponding_Discriminant (D) = Entity (Discrim)
+ then
+ return Node (E);
+ end if;
- C := Constraint (S);
+ Next_Discriminant (D);
+ Next_Elmt (E);
+ end loop;
- -- Digits constraint present
+ -- The Corresponding_Discriminant mechanism is incomplete, because
+ -- the correspondence between new and old discriminants is not one
+ -- to one: one new discriminant can constrain several old ones. In
+ -- that case, scan sequentially the stored_constraint, the list of
+ -- discriminants of the parents, and the constraints.
- if Nkind (C) = N_Digits_Constraint then
+ -- Previous code checked for the present of the Stored_Constraint
+ -- list for the derived type, but did not use it at all. Should it
+ -- be present when the component is a discriminated task type?
- Check_SPARK_Restriction ("digits constraint is not allowed", S);
- Check_Restriction (No_Obsolescent_Features, C);
+ if Is_Derived_Type (Typ)
+ and then Scope (Entity (Discrim)) = Etype (Typ)
+ then
+ D := First_Discriminant (Etype (Typ));
+ E := First_Elmt (Constraints);
+ while Present (D) loop
+ if D = Entity (Discrim) then
+ return Node (E);
+ end if;
- if Warn_On_Obsolescent_Feature then
- Error_Msg_N
- ("subtype digits constraint is an " &
- "obsolescent feature (RM J.3(8))?j?", C);
+ Next_Discriminant (D);
+ Next_Elmt (E);
+ end loop;
end if;
- D := Digits_Expression (C);
- Analyze_And_Resolve (D, Any_Integer);
- Check_Digits_Expression (D);
- Set_Digits_Value (Def_Id, Expr_Value (D));
+ -- Something is wrong if we did not find the value
- -- Check that digits value is in range. Obviously we can do this
- -- at compile time, but it is strictly a runtime check, and of
- -- course there is an ACVC test that checks this.
+ raise Program_Error;
+ end Get_Discr_Value;
- 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;
+ ---------------------
+ -- Is_Discriminant --
+ ---------------------
- C := Range_Constraint (C);
+ function Is_Discriminant (Expr : Node_Id) return Boolean is
+ Discrim_Scope : Entity_Id;
- -- No digits constraint present
+ begin
+ if Denotes_Discriminant (Expr) then
+ Discrim_Scope := Scope (Entity (Expr));
- else
- Set_Digits_Value (Def_Id, Digits_Value (T));
- end if;
+ -- Either we have a reference to one of Typ's discriminants,
- -- Range constraint present
+ pragma Assert (Discrim_Scope = Typ
- if Nkind (C) = N_Range_Constraint then
- Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
+ -- or to the discriminants of the parent type, in the case
+ -- of a derivation of a tagged type with variants.
- -- No range constraint present
+ or else Discrim_Scope = Etype (Typ)
+ or else Full_View (Discrim_Scope) = Etype (Typ)
- else
- pragma Assert (No (C));
- Set_Scalar_Range (Def_Id, Scalar_Range (T));
- end if;
+ -- or same as above for the case where the discriminants
+ -- were declared in Typ's private view.
- Set_Is_Constrained (Def_Id);
- end Constrain_Float;
+ or else (Is_Private_Type (Discrim_Scope)
+ and then Chars (Discrim_Scope) = Chars (Typ))
- ---------------------
- -- Constrain_Index --
- ---------------------
+ -- or else we are deriving from the full view and the
+ -- discriminant is declared in the private entity.
- procedure Constrain_Index
- (Index : Node_Id;
- S : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id;
- Suffix : Character;
- Suffix_Index : Nat)
- is
- Def_Id : Entity_Id;
- R : Node_Id := Empty;
- T : constant Entity_Id := Etype (Index);
+ or else (Is_Private_Type (Typ)
+ and then Chars (Discrim_Scope) = Chars (Typ))
- begin
- if Nkind (S) = N_Range
- or else
- (Nkind (S) = N_Attribute_Reference
- and then Attribute_Name (S) = Name_Range)
- then
- -- A Range attribute will be transformed into N_Range by Resolve
+ -- Or we are constrained the corresponding record of a
+ -- synchronized type that completes a private declaration.
- Analyze (S);
- Set_Etype (S, T);
- R := S;
+ or else (Is_Concurrent_Record_Type (Typ)
+ and then
+ Corresponding_Concurrent_Type (Typ) = Discrim_Scope)
- Process_Range_Expr_In_Decl (R, T);
+ -- or we have a class-wide type, in which case make sure the
+ -- discriminant found belongs to the root type.
- if not Error_Posted (S)
- and then
- (Nkind (S) /= N_Range
- or else not Covers (T, (Etype (Low_Bound (S))))
- or else not Covers (T, (Etype (High_Bound (S)))))
- then
- if Base_Type (T) /= Any_Type
- and then Etype (Low_Bound (S)) /= Any_Type
- and then Etype (High_Bound (S)) /= Any_Type
- then
- Error_Msg_N ("range expected", S);
- end if;
+ or else (Is_Class_Wide_Type (Typ)
+ and then Etype (Typ) = Discrim_Scope));
+
+ return True;
end if;
- elsif Nkind (S) = N_Subtype_Indication then
+ -- In all other cases we have something wrong
- -- The parser has verified that this is a discrete indication
+ return False;
+ end Is_Discriminant;
- Resolve_Discrete_Subtype_Indication (S, T);
- R := Range_Expression (Constraint (S));
+ -- Start of processing for Constrain_Component_Type
- -- Capture values of bounds and generate temporaries for them if
- -- needed, since checks may cause duplication of the expressions
- -- which must not be reevaluated.
+ begin
+ if Nkind (Parent (Comp)) = N_Component_Declaration
+ and then Comes_From_Source (Parent (Comp))
+ and then Comes_From_Source
+ (Subtype_Indication (Component_Definition (Parent (Comp))))
+ and then
+ Is_Entity_Name
+ (Subtype_Indication (Component_Definition (Parent (Comp))))
+ then
+ return Compon_Type;
- -- The forced evaluation removes side effects from expressions, which
- -- should occur also in GNATprove mode. Otherwise, we end up with
- -- unexpected insertions of actions at places where this is not
- -- supposed to occur, e.g. on default parameters of a call.
+ elsif Is_Array_Type (Compon_Type) then
+ return Build_Constrained_Array_Type (Compon_Type);
- if Expander_Active or GNATprove_Mode then
- Force_Evaluation (Low_Bound (R));
- Force_Evaluation (High_Bound (R));
- end if;
+ elsif Has_Discriminants (Compon_Type) then
+ return Build_Constrained_Discriminated_Type (Compon_Type);
- elsif Nkind (S) = N_Discriminant_Association then
+ elsif Is_Access_Type (Compon_Type) then
+ return Build_Constrained_Access_Type (Compon_Type);
- -- Syntactically valid in subtype indication
+ else
+ return Compon_Type;
+ end if;
+ end Constrain_Component_Type;
- Error_Msg_N ("invalid index constraint", S);
- Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
- return;
+ --------------------------
+ -- Constrain_Concurrent --
+ --------------------------
- -- Subtype_Mark case, no anonymous subtypes to construct
+ -- For concurrent types, the associated record value type carries the same
+ -- discriminants, so when we constrain a concurrent type, we must constrain
+ -- the corresponding record type as well.
- else
- Analyze (S);
+ procedure Constrain_Concurrent
+ (Def_Id : in out Entity_Id;
+ SI : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character)
+ is
+ -- Retrieve Base_Type to ensure getting to the concurrent type in the
+ -- case of a private subtype (needed when only doing semantic analysis).
- if Is_Entity_Name (S) then
- if not Is_Type (Entity (S)) then
- Error_Msg_N ("expect subtype mark for index constraint", S);
+ T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI)));
+ T_Val : Entity_Id;
- elsif Base_Type (Entity (S)) /= Base_Type (T) then
- Wrong_Type (S, Base_Type (T));
+ begin
+ if Is_Access_Type (T_Ent) then
+ T_Ent := Designated_Type (T_Ent);
+ end if;
- -- Check error of subtype with predicate in index constraint
+ T_Val := Corresponding_Record_Type (T_Ent);
- else
- Bad_Predicated_Subtype_Use
- ("subtype& has predicate, not allowed in index constraint",
- S, Entity (S));
- end if;
+ if Present (T_Val) then
- return;
+ if No (Def_Id) then
+ Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
+ end if;
- else
- Error_Msg_N ("invalid index constraint", S);
- Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
- return;
+ 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));
+
+ else
+ -- If there is no associated record, expansion is disabled and this
+ -- is a generic context. Create a subtype in any case, so that
+ -- semantic analysis can proceed.
+
+ if No (Def_Id) then
+ Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
end if;
- end if;
- Def_Id :=
- Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
+ Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+ end if;
+ end Constrain_Concurrent;
- Set_Etype (Def_Id, Base_Type (T));
+ ------------------------------------
+ -- Constrain_Corresponding_Record --
+ ------------------------------------
- if Is_Modular_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Modular_Integer_Subtype);
+ function Constrain_Corresponding_Record
+ (Prot_Subt : Entity_Id;
+ Corr_Rec : Entity_Id;
+ Related_Nod : Node_Id) return Entity_Id
+ is
+ T_Sub : constant Entity_Id :=
+ Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C');
- elsif Is_Integer_Type (T) then
- Set_Ekind (Def_Id, E_Signed_Integer_Subtype);
+ begin
+ Set_Etype (T_Sub, Corr_Rec);
+ Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
+ Set_Is_Constrained (T_Sub, True);
+ Set_First_Entity (T_Sub, First_Entity (Corr_Rec));
+ Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec));
- else
- Set_Ekind (Def_Id, E_Enumeration_Subtype);
- Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
- Set_First_Literal (Def_Id, First_Literal (T));
+ if Has_Discriminants (Prot_Subt) then -- False only if errors.
+ Set_Discriminant_Constraint
+ (T_Sub, Discriminant_Constraint (Prot_Subt));
+ Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub);
+ Create_Constrained_Components
+ (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub));
end if;
- 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_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub));
- Set_Scalar_Range (Def_Id, R);
+ if Ekind (Scope (Prot_Subt)) /= E_Record_Type then
+ Conditional_Delay (T_Sub, Corr_Rec);
- Set_Etype (S, Def_Id);
- Set_Discrete_RM_Size (Def_Id);
- end Constrain_Index;
+ else
+ -- This is a component subtype: it will be frozen in the context of
+ -- the enclosing record's init_proc, so that discriminant references
+ -- are resolved to discriminals. (Note: we used to skip freezing
+ -- altogether in that case, which caused errors downstream for
+ -- components of a bit packed array type).
+
+ Set_Has_Delayed_Freeze (T_Sub);
+ end if;
+
+ return T_Sub;
+ end Constrain_Corresponding_Record;
-----------------------
- -- Constrain_Integer --
+ -- Constrain_Decimal --
-----------------------
- 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);
+ 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_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
+ 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);
- 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;
+ pragma Assert (Nkind (C) = N_Digits_Constraint);
- Set_Etype (Def_Id, Base_Type (T));
- Set_Size_Info (Def_Id, (T));
- Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
+ Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
+
+ 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);
+
+ -- Manufacture range from given digits value if no range present
+
+ 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);
- end Constrain_Integer;
- ------------------------------
- -- Constrain_Ordinary_Fixed --
- ------------------------------
+ -- Unconditionally delay the freeze, since we cannot set size
+ -- information in all cases correctly until the freeze point.
- procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is
+ Set_Has_Delayed_Freeze (Def_Id);
+ end Constrain_Decimal;
+
+ ----------------------------------
+ -- Constrain_Discriminated_Type --
+ ----------------------------------
+
+ procedure Constrain_Discriminated_Type
+ (Def_Id : Entity_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id;
+ For_Access : Boolean := False)
+ is
+ E : constant Entity_Id := Entity (Subtype_Mark (S));
+ T : Entity_Id;
+ C : Node_Id;
+ Elist : Elist_Id := New_Elmt_List;
+
+ procedure Fixup_Bad_Constraint;
+ -- This is called after finding a bad constraint, and after having
+ -- posted an appropriate error message. The mission is to leave the
+ -- entity T in as reasonable state as possible.
+
+ --------------------------
+ -- Fixup_Bad_Constraint --
+ --------------------------
+
+ procedure Fixup_Bad_Constraint is
+ begin
+ -- Set a reasonable Ekind for the entity. For an incomplete type,
+ -- we can't do much, but for other types, we can set the proper
+ -- corresponding subtype kind.
+
+ if 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 to the known type, to reduce chances of cascaded errors
+
+ Set_Etype (Def_Id, E);
+ Set_Error_Posted (Def_Id);
+ end Fixup_Bad_Constraint;
+
+ -- Start of processing for Constrain_Discriminated_Type
+
+ begin
+ C := Constraint (S);
+
+ -- A discriminant constraint is only allowed in a subtype indication,
+ -- after a subtype mark. This subtype mark must denote either a type
+ -- with discriminants, or an access type whose designated type is a
+ -- type with discriminants. A discriminant constraint specifies the
+ -- values of these discriminants (RM 3.7.2(5)).
+
+ T := Base_Type (Entity (Subtype_Mark (S)));
+
+ if Is_Access_Type (T) then
+ T := Designated_Type (T);
+ end if;
+
+ -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
+ -- Avoid generating an error for access-to-incomplete subtypes.
+
+ if Ada_Version >= Ada_2005
+ and then Ekind (T) = E_Incomplete_Type
+ and then Nkind (Parent (S)) = N_Subtype_Declaration
+ and then not Is_Itype (Def_Id)
+ then
+ -- A little sanity check, emit an error message if the type
+ -- has discriminants to begin with. Type T may be a regular
+ -- incomplete type or imported via a limited with clause.
+
+ if Has_Discriminants (T)
+ or else (From_Limited_With (T)
+ and then Present (Non_Limited_View (T))
+ and then Nkind (Parent (Non_Limited_View (T))) =
+ N_Full_Type_Declaration
+ and then Present (Discriminant_Specifications
+ (Parent (Non_Limited_View (T)))))
+ then
+ Error_Msg_N
+ ("(Ada 2005) incomplete subtype may not be constrained", C);
+ else
+ Error_Msg_N ("invalid constraint: type has no discriminant", C);
+ end if;
+
+ Fixup_Bad_Constraint;
+ return;
+
+ -- Check that the type has visible discriminants. The type may be
+ -- a private type with unknown discriminants whose full view has
+ -- discriminants which are invisible.
+
+ elsif not Has_Discriminants (T)
+ or else
+ (Has_Unknown_Discriminants (T)
+ and then Is_Private_Type (T))
+ then
+ Error_Msg_N ("invalid constraint: type has no discriminant", C);
+ Fixup_Bad_Constraint;
+ return;
+
+ 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 may be an unconstrained subtype (e.g. a generic actual).
+ -- Constraint applies to the base type.
+
+ T := Base_Type (T);
+
+ Elist := Build_Discriminant_Constraints (T, S);
+
+ -- If the list returned was empty we had an error in building the
+ -- discriminant constraint. We have also already signalled an error
+ -- in the incomplete type case
+
+ if Is_Empty_Elmt_List (Elist) then
+ Fixup_Bad_Constraint;
+ return;
+ end if;
+
+ Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
+ end Constrain_Discriminated_Type;
+
+ ---------------------------
+ -- Constrain_Enumeration --
+ ---------------------------
+
+ procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is
+ T : constant Entity_Id := Entity (Subtype_Mark (S));
+ C : constant Node_Id := Constraint (S);
+
+ 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;
+
+ ----------------------
+ -- Constrain_Float --
+ ----------------------
+
+ 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_Ordinary_Fixed_Point_Subtype);
+ 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));
- Set_Small_Value (Def_Id, Small_Value (T));
-- Process the constraint
C := Constraint (S);
- -- Delta constraint present
+ -- Digits constraint present
- if Nkind (C) = N_Delta_Constraint then
+ if Nkind (C) = N_Digits_Constraint then
- Check_SPARK_Restriction ("delta constraint is not allowed", S);
+ Check_SPARK_05_Restriction ("digits constraint is not allowed", S);
Check_Restriction (No_Obsolescent_Features, C);
if Warn_On_Obsolescent_Feature then
- Error_Msg_S
- ("subtype delta constraint is an " &
- "obsolescent feature (RM J.3(7))?j?");
+ Error_Msg_N
+ ("subtype digits constraint is an " &
+ "obsolescent feature (RM J.3(8))?j?", C);
end if;
- D := Delta_Expression (C);
- Analyze_And_Resolve (D, Any_Real);
- Check_Delta_Expression (D);
- Set_Delta_Value (Def_Id, Expr_Value_R (D));
+ D := Digits_Expression (C);
+ Analyze_And_Resolve (D, Any_Integer);
+ Check_Digits_Expression (D);
+ Set_Digits_Value (Def_Id, Expr_Value (D));
- -- Check that delta value is in range. Obviously we can do this
+ -- Check that digits value is in range. Obviously we can do this
-- at compile time, but it is strictly a runtime check, and of
-- course there is an ACVC test that checks this.
- if Delta_Value (Def_Id) < Delta_Value (T) then
- Error_Msg_N ("??delta value is too small", 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);
C := Range_Constraint (C);
- -- No delta constraint present
+ -- No digits constraint present
else
- Set_Delta_Value (Def_Id, Delta_Value (T));
+ Set_Digits_Value (Def_Id, Digits_Value (T));
end if;
-- Range constraint present
else
pragma Assert (No (C));
Set_Scalar_Range (Def_Id, Scalar_Range (T));
-
end if;
- Set_Discrete_RM_Size (Def_Id);
-
- -- Unconditionally delay the freeze, since we cannot set size
- -- information in all cases correctly until the freeze point.
+ Set_Is_Constrained (Def_Id);
+ end Constrain_Float;
- Set_Has_Delayed_Freeze (Def_Id);
- end Constrain_Ordinary_Fixed;
+ ---------------------
+ -- Constrain_Index --
+ ---------------------
- -----------------------
- -- Contain_Interface --
+ procedure Constrain_Index
+ (Index : Node_Id;
+ S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id;
+ Suffix : Character;
+ Suffix_Index : Nat)
+ is
+ Def_Id : Entity_Id;
+ R : Node_Id := Empty;
+ T : constant Entity_Id := Etype (Index);
+
+ begin
+ Def_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index);
+ Set_Etype (Def_Id, Base_Type (T));
+
+ if Nkind (S) = N_Range
+ or else
+ (Nkind (S) = N_Attribute_Reference
+ and then Attribute_Name (S) = Name_Range)
+ then
+ -- A Range attribute will be transformed into N_Range by Resolve
+
+ Analyze (S);
+ Set_Etype (S, T);
+ R := S;
+
+ Process_Range_Expr_In_Decl (R, T);
+
+ if not Error_Posted (S)
+ and then
+ (Nkind (S) /= N_Range
+ or else not Covers (T, (Etype (Low_Bound (S))))
+ or else not Covers (T, (Etype (High_Bound (S)))))
+ then
+ if Base_Type (T) /= Any_Type
+ and then Etype (Low_Bound (S)) /= Any_Type
+ and then Etype (High_Bound (S)) /= Any_Type
+ then
+ Error_Msg_N ("range expected", S);
+ end if;
+ end if;
+
+ elsif Nkind (S) = N_Subtype_Indication then
+
+ -- The parser has verified that this is a discrete indication
+
+ Resolve_Discrete_Subtype_Indication (S, T);
+ Bad_Predicated_Subtype_Use
+ ("subtype& has predicate, not allowed in index constraint",
+ S, Entity (Subtype_Mark (S)));
+
+ R := Range_Expression (Constraint (S));
+
+ -- Capture values of bounds and generate temporaries for them if
+ -- needed, since checks may cause duplication of the expressions
+ -- which must not be reevaluated.
+
+ -- The forced evaluation removes side effects from expressions, which
+ -- should occur also in GNATprove mode. Otherwise, we end up with
+ -- unexpected insertions of actions at places where this is not
+ -- supposed to occur, e.g. on default parameters of a call.
+
+ if Expander_Active or GNATprove_Mode then
+ Force_Evaluation
+ (Low_Bound (R), Related_Id => Def_Id, Is_Low_Bound => True);
+ Force_Evaluation
+ (High_Bound (R), Related_Id => Def_Id, Is_High_Bound => True);
+ end if;
+
+ elsif Nkind (S) = N_Discriminant_Association then
+
+ -- Syntactically valid in subtype indication
+
+ Error_Msg_N ("invalid index constraint", S);
+ Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
+ return;
+
+ -- Subtype_Mark case, no anonymous subtypes to construct
+
+ 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));
+
+ -- Check error of subtype with predicate in index constraint
+
+ else
+ Bad_Predicated_Subtype_Use
+ ("subtype& has predicate, not allowed in index constraint",
+ S, Entity (S));
+ end if;
+
+ return;
+
+ else
+ Error_Msg_N ("invalid index constraint", S);
+ Rewrite (S, New_Occurrence_Of (T, Sloc (S)));
+ return;
+ end if;
+ end if;
+
+ -- Complete construction of the Itype
+
+ 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));
+ Set_First_Literal (Def_Id, First_Literal (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;
+
+ -----------------------
+ -- Constrain_Integer --
+ -----------------------
+
+ 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;
+
+ ------------------------------
+ -- Constrain_Ordinary_Fixed --
+ ------------------------------
+
+ 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));
+
+ -- Process the constraint
+
+ C := Constraint (S);
+
+ -- Delta constraint present
+
+ if Nkind (C) = N_Delta_Constraint then
+
+ Check_SPARK_05_Restriction ("delta constraint is not allowed", S);
+ Check_Restriction (No_Obsolescent_Features, C);
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_S
+ ("subtype delta constraint is an " &
+ "obsolescent feature (RM J.3(7))?j?");
+ end if;
+
+ D := Delta_Expression (C);
+ Analyze_And_Resolve (D, Any_Real);
+ Check_Delta_Expression (D);
+ Set_Delta_Value (Def_Id, Expr_Value_R (D));
+
+ -- Check that delta value is in range. Obviously we can do this
+ -- at compile time, but it is strictly a runtime check, and of
+ -- course there is an ACVC test that checks this.
+
+ 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);
+
+ -- No delta constraint present
+
+ else
+ Set_Delta_Value (Def_Id, Delta_Value (T));
+ end if;
+
+ -- Range constraint present
+
+ if Nkind (C) = N_Range_Constraint then
+ Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
+
+ -- No range constraint present
+
+ else
+ pragma Assert (No (C));
+ Set_Scalar_Range (Def_Id, Scalar_Range (T));
+ end if;
+
+ Set_Discrete_RM_Size (Def_Id);
+
+ -- Unconditionally delay the freeze, since we cannot set size
+ -- information in all cases correctly until the freeze point.
+
+ Set_Has_Delayed_Freeze (Def_Id);
+ end Constrain_Ordinary_Fixed;
+
+ -----------------------
+ -- Contain_Interface --
-----------------------
function Contain_Interface
Conditional_Delay (Full, Priv);
if Is_Tagged_Type (Full) then
- Set_Direct_Primitive_Operations (Full,
- Direct_Primitive_Operations (Priv));
+ Set_Direct_Primitive_Operations
+ (Full, Direct_Primitive_Operations (Priv));
+ Set_No_Tagged_Streams_Pragma
+ (Full, No_Tagged_Streams_Pragma (Priv));
if Is_Base_Type (Priv) then
Set_Class_Wide_Type (Full, Class_Wide_Type (Priv));
begin
Set_Size_Info (T1, T2);
- Set_First_Index (T1, First_Index (T2));
- Set_Is_Aliased (T1, Is_Aliased (T2));
- Set_Is_Volatile (T1, Is_Volatile (T2));
- Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2));
- Set_Is_Constrained (T1, Is_Constrained (T2));
- Set_Depends_On_Private (T1, Has_Private_Component (T2));
- Set_First_Rep_Item (T1, First_Rep_Item (T2));
- Set_Convention (T1, Convention (T2));
- Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
- Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
- Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2));
+ Set_First_Index (T1, First_Index (T2));
+ Set_Is_Aliased (T1, Is_Aliased (T2));
+ Set_Is_Volatile (T1, Is_Volatile (T2));
+ Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2));
+ Set_Is_Constrained (T1, Is_Constrained (T2));
+ Set_Depends_On_Private (T1, Has_Private_Component (T2));
+ Inherit_Rep_Item_Chain (T1, T2);
+ Set_Convention (T1, Convention (T2));
+ Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
+ Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
+ Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2));
end Copy_Array_Subtype_Attributes;
-----------------------------------
-- The tag and the possible parent component are unconditionally in
-- the subtype.
- if Is_Tagged_Type (Typ)
- or else Has_Controlled_Component (Typ)
- then
+ if Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
Old_C := First_Component (Typ);
while Present (Old_C) loop
if Nam_In (Chars (Old_C), Name_uTag, Name_uParent) then
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);
+ Gather_Components
+ (Typ,
+ Component_List (Type_Definition (Parent (Parent_Type))),
+ Governed_By => Assoc_List,
+ Into => Comp_List,
+ Report_Errors => Errors);
+
+ -- Note: previously there was a check at this point that no errors
+ -- were detected. As a consequence of AI05-220 there may be an error
+ -- if an inherited discriminant that controls a variant has a non-
+ -- static constraint.
-- If the tagged derivation has a type extension, collect all the
-- new components therein.
- if Present
- (Record_Extension_Part (Type_Definition (Parent (Typ))))
+ if Present (Record_Extension_Part (Type_Definition (Parent (Typ))))
then
Old_C := First_Component (Typ);
while Present (Old_C) loop
Bound_Val : Ureal;
begin
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("decimal fixed point type is not allowed", Def);
Check_Restriction (No_Fixed_Point, Def);
Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
end if;
- -- Complete entity for first subtype
+ -- Complete entity for first subtype. The inheritance of the rep item
+ -- chain ensures that SPARK-related pragmas are not clobbered when the
+ -- decimal fixed point type acts as a full view of a private type.
- 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);
+ Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
+ Set_Size_Info (T, Implicit_Base);
+ Inherit_Rep_Item_Chain (T, Implicit_Base);
+ Set_Digits_Value (T, Digs_Val);
+ Set_Delta_Value (T, Delta_Val);
+ Set_Small_Value (T, Delta_Val);
+ Set_Scale_Value (T, Scale_Val);
+ Set_Is_Constrained (T);
end Decimal_Fixed_Point_Type_Declaration;
-----------------------------------
-- Start of processing for Derive_Subprogram
begin
- New_Subp :=
- New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
+ New_Subp := New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
Set_Ekind (New_Subp, Ekind (Parent_Subp));
- Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp)));
-- Check whether the inherited subprogram is a private operation that
-- should be inherited but not yet made visible. Such subprograms can
Set_Alias (New_Subp, Actual_Subp);
end if;
+ -- Inherit the "ghostness" from the parent subprogram
+
+ if Is_Ghost_Entity (Alias (New_Subp)) then
+ Set_Is_Ghost_Entity (New_Subp);
+ end if;
+
-- Derived subprograms of a tagged type must inherit the convention
-- of the parent subprogram (a requirement of AI-117). Derived
-- subprograms of untagged types simply get convention Ada by default.
-- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract"
-- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2).
+ -- A subprogram subject to pragma Extensions_Visible with value False
+ -- requires overriding if the subprogram has at least one controlling
+ -- OUT parameter (SPARK RM 6.1.7(6)).
+
elsif Ada_Version >= Ada_2005
and then (Is_Abstract_Subprogram (Alias (New_Subp))
or else (Is_Tagged_Type (Derived_Type)
E_Anonymous_Access_Type
and then Designated_Type (Etype (New_Subp)) =
Derived_Type
- and then not Is_Null_Extension (Derived_Type)))
+ and then not Is_Null_Extension (Derived_Type))
+ or else (Comes_From_Source (Alias (New_Subp))
+ and then Is_EVF_Procedure (Alias (New_Subp))))
and then No (Actual_Subp)
then
if not Is_Tagged_Type (Derived_Type)
if Present (DTC_Entity (Actual_Subp)) then
Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
- Set_DT_Position (New_Subp, DT_Position (Actual_Subp));
+ Set_DT_Position_Value (New_Subp, DT_Position (Actual_Subp));
end if;
end if;
loop
exit when No (Partial_View)
or else (Has_Private_Declaration (Partial_View)
- and then
- Full_View (Partial_View) = Derived_Type);
+ and then
+ Full_View (Partial_View) = Derived_Type);
Next_Entity (Partial_View);
end loop;
-- parent is also an interface.
if Interface_Present (Def) then
- Check_SPARK_Restriction ("interface is not allowed", Def);
+ Check_SPARK_05_Restriction ("interface is not allowed", Def);
if not Is_Interface (Parent_Type) then
Diagnose_Interface (Indic, Parent_Type);
-- subtype of Any_Type, and set a few attributes to prevent cascaded
-- errors. If this is a self-definition, emit error now.
- if T = Parent_Type
- or else T = Etype (Parent_Type)
- 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;
end if;
-- Only composite types other than array types are allowed to have
- -- discriminants. In SPARK, no types are allowed to have discriminants.
+ -- discriminants.
if Present (Discriminant_Specifications (N)) then
if (Is_Elementary_Type (Parent_Type)
- or else Is_Array_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);
+
+ -- The type is allowed to have discriminants
+
else
- Check_SPARK_Restriction ("discriminant type is not allowed", N);
+ Check_SPARK_05_Restriction ("discriminant type is not allowed", N);
end if;
end if;
Taggd := Is_Tagged_Type (Parent_Type);
- -- Perhaps the parent type should be changed to the class-wide type's
- -- specific type in this case to prevent cascading errors ???
+ -- Set the parent type to the class-wide type's specific type in this
+ -- case to prevent cascading errors
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);
+ Set_Etype (T, Etype (Parent_Type));
return;
end if;
begin
if Nkind (Decl) = N_Formal_Type_Declaration
and then Nkind (Formal_Type_Definition (Decl)) =
- N_Formal_Derived_Type_Definition
+ N_Formal_Derived_Type_Definition
and then Synchronized_Present (Formal_Type_Definition (Decl))
and then No (Extension)
-- extensions of tagged record types.
if No (Extension) then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("derived type is not allowed", Original_Node (N));
end if;
end Derived_Type_Declaration;
procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is
begin
- if not Is_Interface (E)
- and then E /= Any_Type
- then
+ if not Is_Interface (E) and then E /= Any_Type then
Error_Msg_NE ("(Ada 2005) & must be an interface", N, E);
end if;
end Diagnose_Interface;
-- Start of processing for Expand_To_Stored_Constraint
begin
- if No (Constraint)
- or else Is_Empty_Elmt_List (Constraint)
- then
+ if No (Constraint) or else Is_Empty_Elmt_List (Constraint) then
return No_Elist;
end if;
while Present (F_Spec) loop
P_Spec := First (Prev_Aspects);
while Present (P_Spec) loop
- if
- Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec))
+ if Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec))
then
Error_Msg_N
("aspect already specified in private declaration",
Set_Ekind (Id, Ekind (Prev)); -- will be reset later
Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
- -- If the incomplete type is completed by a private declaration
- -- the class-wide type remains associated with the incomplete
- -- type, to prevent order-of-elaboration issues in gigi, else
- -- we associate the class-wide type with the known full view.
+ -- The type of the classwide type is the current Id. Previously
+ -- this was not done for private declarations because of order-
+ -- of elaboration issues in the back-end, but gigi now handles
+ -- this properly.
- if Nkind (N) /= N_Private_Type_Declaration then
- Set_Etype (Class_Wide_Type (Id), Id);
- end if;
+ Set_Etype (Class_Wide_Type (Id), Id);
end if;
-- Case of full declaration of private type
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
+ -- AI12-0133: Indicate whether we have a partial view with
+ -- unknown discriminants, in which case initialization of objects
+ -- of the type do not receive an invariant check.
+
+ Set_Partial_View_Has_Unknown_Discr
+ (Prev, Has_Unknown_Discriminants (Id));
+
-- Preserve aspect and iterator flags that may have been set on
-- the partial view.
if Is_Type (Prev)
and then (Is_Tagged_Type (Prev)
- or else Present (Class_Wide_Type (Prev)))
+ or else Present (Class_Wide_Type (Prev)))
then
-- Ada 2012 (AI05-0162): A private type may be the completion of
-- an incomplete type.
elsif Nkind_In (N, N_Task_Type_Declaration,
N_Protected_Type_Declaration)
then
- if No (Interface_List (N))
- and then not Error_Posted (N)
- then
+ if No (Interface_List (N)) and then not Error_Posted (N) then
Tag_Mismatch;
end if;
-- Check that requested number of digits is not too high.
if Digs_Val > Max_Digs_Val then
+
-- The check for Max_Base_Digits may be somewhat expensive, as it
-- requires reading System, so only do it when necessary.
Set_Scalar_Range (T, Scalar_Range (Base_Typ));
end if;
- -- Complete definition of implicit base and declared first subtype
-
- 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_Float_Rep (Implicit_Base, Float_Rep (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);
+ -- Complete definition of implicit base and declared first subtype. The
+ -- inheritance of the rep item chain ensures that SPARK-related pragmas
+ -- are not clobbered when the floating point type acts as a full view of
+ -- a private type.
+
+ 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_Float_Rep (Implicit_Base, Float_Rep (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));
+ Inherit_Rep_Item_Chain (T, Implicit_Base);
+ Set_Digits_Value (T, Digs_Val);
end Floating_Point_Type_Declaration;
----------------------------
Result_Entity := Entity (Result);
end if;
- -- See if this level of derivation actually has discriminants
- -- because tagged derivations can add them, hence the lower
- -- levels need not have any.
+ -- See if this level of derivation actually has discriminants because
+ -- tagged derivations can add them, hence the lower levels need not
+ -- have any.
if not Has_Discriminants (Ti) then
return Result;
end if;
- -- Scan Ti's discriminants for Result_Entity,
- -- and return its corresponding value, if any.
+ -- Scan Ti's discriminants for Result_Entity, and return its
+ -- corresponding value, if any.
Result_Entity := Original_Record_Component (Result_Entity);
end loop;
-- Could not find it
- --
+
return Result;
end Search_Derivation_Levels;
elsif Nkind (C) = N_Digits_Constraint then
return
Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N)))
- or else
- Present (Range_Constraint (C));
+ or else Present (Range_Constraint (C));
elsif Nkind (C) = N_Delta_Constraint then
return Present (Range_Constraint (C));
-- Start of processing for Inherit_Component
begin
- pragma Assert (not Is_Tagged or else not Stored_Discrim);
+ pragma Assert (not Is_Tagged or not Stored_Discrim);
Set_Parent (New_C, Parent (Old_C));
elsif (Is_Private_Type (Derived_Base)
and then not Is_Generic_Type (Derived_Base))
or else (Is_Empty_Elmt_List (Discs)
- and then not Expander_Active)
+ and then not Expander_Active)
then
Set_Etype (New_C, Etype (Old_C));
and then not Is_Tagged
and then
(not Inherit_Discr
- or else First_Discriminant (Parent_Base) /=
- First_Stored_Discriminant (Parent_Base))
+ or else First_Discriminant (Parent_Base) /=
+ First_Stored_Discriminant (Parent_Base))
then
Stored_Discrim := First_Stored_Discriminant (Parent_Base);
while Present (Stored_Discrim) loop
and then Present (First_Discriminant (Derived_Base))
and then
(not Is_Private_Type (Derived_Base)
- or else Is_Completely_Hidden
- (First_Stored_Discriminant (Derived_Base))
- or else Is_Generic_Type (Derived_Base))
+ or else Is_Completely_Hidden
+ (First_Stored_Discriminant (Derived_Base))
+ or else Is_Generic_Type (Derived_Base))
then
D := First_Discriminant (Derived_Base);
while Present (D) loop
procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
begin
+ Set_Has_Predicates (Subt, Has_Predicates (Par));
Set_Has_Static_Predicate_Aspect
(Subt, Has_Static_Predicate_Aspect (Par));
Set_Has_Dynamic_Predicate_Aspect
(Subt, Has_Dynamic_Predicate_Aspect (Par));
end Inherit_Predicate_Flags;
+ ----------------------
+ -- Is_EVF_Procedure --
+ ----------------------
+
+ function Is_EVF_Procedure (Subp : Entity_Id) return Boolean is
+ Formal : Entity_Id;
+
+ begin
+ -- Examine the formals of an Extensions_Visible False procedure looking
+ -- for a controlling OUT parameter.
+
+ if Ekind (Subp) = E_Procedure
+ and then Extensions_Visible_Status (Subp) = Extensions_Visible_False
+ then
+ Formal := First_Formal (Subp);
+ while Present (Formal) loop
+ if Ekind (Formal) = E_Out_Parameter
+ and then Is_Controlling_Formal (Formal)
+ then
+ return True;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ return False;
+ end Is_EVF_Procedure;
+
-----------------------
-- Is_Null_Extension --
-----------------------
end loop;
return True;
+
else
return True;
end if;
Type_Scope := Scope (Base_Type (Scope (C)));
end if;
- -- For an untagged type derived from a private type, the only visible
- -- components are new discriminants. In an instance all components are
- -- visible (see Analyze_Selected_Component).
+ -- This test only concerns tagged types
if not Is_Tagged_Type (Original_Scope) then
- return not Has_Private_Ancestor (Original_Scope)
- or else In_Open_Scopes (Scope (Original_Scope))
- or else In_Instance
- or else (Ekind (Original_Comp) = E_Discriminant
- and then Original_Scope = Type_Scope);
+ return True;
-- If it is _Parent or _Tag, there is no visibility issue
Set_Default_SSO (CW_Type);
if Ekind (T) = E_Class_Wide_Subtype then
- Set_Etype (CW_Type, Etype (Base_Type (T)));
+ Set_Etype (CW_Type, Etype (Base_Type (T)));
else
- Set_Etype (CW_Type, T);
+ Set_Etype (CW_Type, T);
end if;
+ Set_No_Tagged_Streams_Pragma (CW_Type, No_Tagged_Streams);
+
-- If this is the class_wide type of a constrained subtype, it does
-- not have discriminants.
Set_Scalar_Range (Def_Id, R);
Conditional_Delay (Def_Id, T);
+ if Nkind (N) = N_Subtype_Indication then
+ Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N)));
+ end if;
+
-- In the subtype indication case, if the immediate parent of the
-- new subtype is non-static, then the subtype we create is non-
-- static, even if its bounds are static.
Init_Esize (T, System_Max_Binary_Modulus_Power);
end if;
- if not Non_Binary_Modulus (T)
- and then Esize (T) = RM_Size (T)
- then
+ if not Non_Binary_Modulus (T) and then Esize (T) = RM_Size (T) then
Set_Is_Known_Valid (T);
end if;
end Set_Modular_Size;
-- Non-binary case
elsif M_Val < 2 ** Bits then
- Check_SPARK_Restriction ("modulus should be a power of 2", T);
+ Check_SPARK_05_Restriction ("modulus should be a power of 2", T);
Set_Non_Binary_Modulus (T);
if Bits > System_Max_Nonbinary_Modulus_Power then
Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val);
Set_Fixed_Range (T, Loc, Low_Val, High_Val);
- -- Complete definition of first subtype
+ -- Complete definition of first subtype. The inheritance of the rep item
+ -- chain ensures that SPARK-related pragmas are not clobbered when the
+ -- ordinary fixed point type acts as a full view of a private type.
+
+ Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
+ Init_Size_Align (T);
+ Inherit_Rep_Item_Chain (T, Implicit_Base);
+ Set_Small_Value (T, Small_Val);
+ Set_Delta_Value (T, Delta_Val);
+ Set_Is_Constrained (T);
+ end Ordinary_Fixed_Point_Type_Declaration;
- 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);
+ ----------------------------------
+ -- Preanalyze_Assert_Expression --
+ ----------------------------------
- end Ordinary_Fixed_Point_Type_Declaration;
+ procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is
+ begin
+ In_Assertion_Expr := In_Assertion_Expr + 1;
+ Preanalyze_Spec_Expression (N, T);
+ In_Assertion_Expr := In_Assertion_Expr - 1;
+ end Preanalyze_Assert_Expression;
+
+ -----------------------------------
+ -- Preanalyze_Default_Expression --
+ -----------------------------------
+
+ procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is
+ Save_In_Default_Expr : constant Boolean := In_Default_Expr;
+ begin
+ In_Default_Expr := True;
+ Preanalyze_Spec_Expression (N, T);
+ In_Default_Expr := Save_In_Default_Expr;
+ end Preanalyze_Default_Expression;
+
+ --------------------------------
+ -- Preanalyze_Spec_Expression --
+ --------------------------------
+
+ procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is
+ Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
+ begin
+ In_Spec_Expression := True;
+ Preanalyze_And_Resolve (N, T);
+ In_Spec_Expression := Save_In_Spec_Expression;
+ end Preanalyze_Spec_Expression;
----------------------------------------
-- Prepare_Private_Subtype_Completion --
Related_Nod : Node_Id)
is
Id_B : constant Entity_Id := Base_Type (Id);
- Full_B : constant Entity_Id := Full_View (Id_B);
+ Full_B : Entity_Id := Full_View (Id_B);
Full : Entity_Id;
begin
if Present (Full_B) then
+ -- Get to the underlying full view if necessary
+
+ if Is_Private_Type (Full_B)
+ and then Present (Underlying_Full_View (Full_B))
+ then
+ Full_B := Underlying_Full_View (Full_B);
+ end if;
+
-- The Base_Type is already completed, we can complete the subtype
-- now. We have to create a new entity with the same name, Thus we
-- can't use Create_Itype.
end if;
end if;
+ -- Handling of discriminants that are access types
+
if Is_Access_Type (Discr_Type) then
- -- Ada 2005 (AI-230): Access discriminant allowed in non-limited
- -- record types
+ -- Ada 2005 (AI-230): Access discriminant allowed in non-
+ -- limited record types
if Ada_Version < Ada_2005 then
Check_Access_Discriminant_Requires_Limited
("(Ada 83) access discriminant not allowed", Discr);
end if;
+ -- If not access type, must be a discrete type
+
elsif not Is_Discrete_Type (Discr_Type) then
- Error_Msg_N ("discriminants must have a discrete or access type",
- Discriminant_Type (Discr));
+ Error_Msg_N
+ ("discriminants must have a discrete or access type",
+ Discriminant_Type (Discr));
end if;
Set_Etype (Defining_Identifier (Discr), Discr_Type);
-- expression of the discriminant; the default expression must be of
-- the type of the discriminant. (RM 3.7.1) Since this expression is
-- a default expression, we do the special preanalysis, since this
- -- expression does not freeze (see "Handling of Default and Per-
- -- Object Expressions" in spec of package Sem).
+ -- expression does not freeze (see section "Handling of Default and
+ -- Per-Object Expressions" in spec of package Sem).
if Present (Expression (Discr)) then
Preanalyze_Spec_Expression (Expression (Discr), Discr_Type);
+ -- Legaity checks
+
if Nkind (N) = N_Formal_Type_Declaration then
Error_Msg_N
("discriminant defaults not allowed for formal type",
(Defining_Identifier (Discr), Expression (Discr));
end if;
+ -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag
+ -- gets set unless we can be sure that no range check is required.
+
+ if (GNATprove_Mode or not Expander_Active)
+ and then not
+ Is_In_Range
+ (Expression (Discr), Discr_Type, Assume_Valid => True)
+ then
+ Set_Do_Range_Check (Expression (Discr));
+ end if;
+
+ -- No default discriminant value given
+
else
Default_Not_Present := True;
end if;
null;
else
- Error_Msg_N ("access discriminants of nonlimited types",
- Expression (Discr));
- Error_Msg_N ("\cannot have defaults", Expression (Discr));
+ Error_Msg_N
+ ("access discriminants of nonlimited types cannot "
+ & "have defaults", Expression (Discr));
end if;
elsif Present (Expression (Discr)) then
Error_Msg_N
- ("(Ada 2005) access discriminants of nonlimited types",
- Expression (Discr));
- Error_Msg_N ("\cannot have defaults", Expression (Discr));
+ ("(Ada 2005) access discriminants of nonlimited types "
+ & "cannot have defaults", Expression (Discr));
end if;
end if;
end if;
-----------------------
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;
-
procedure Collect_Implemented_Interfaces
(Typ : Entity_Id;
Ifaces : Elist_Id);
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
- begin
- -- Abstract interfaces are only associated with tagged record types
-
- if not Is_Tagged_Type (Typ)
- or else not Is_Record_Type (Typ)
- then
- return;
- end if;
-
- -- Recursively climb to the ancestors
-
- if Etype (Typ) /= Typ
-
- -- Protect the frontend against wrong cyclic declarations like:
-
- -- type B is new A with private;
- -- type C is new A with private;
- -- private
- -- type B is new C with null record;
- -- type C is new B with null record;
-
- and then Etype (Typ) /= Priv_T
- and then Etype (Typ) /= Full_T
- then
- -- Keep separate the management of private type declarations
-
- if Ekind (Typ) = E_Record_Type_With_Private then
-
- -- Handle the following illegal usage:
- -- type Private_Type is tagged private;
- -- private
- -- type Private_Type is new Type_Implementing_Iface;
-
- if Present (Full_View (Typ))
- and then Etype (Typ) /= Full_View (Typ)
- then
- if Is_Interface (Etype (Typ)) then
- Append_Unique_Elmt (Etype (Typ), Ifaces);
- end if;
-
- Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
- end if;
-
- -- Non-private types
-
- else
- if Is_Interface (Etype (Typ)) then
- Append_Unique_Elmt (Etype (Typ), Ifaces);
- end if;
-
- Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
- end if;
- end if;
-
- -- Handle entities in the list of abstract interfaces
-
- if Present (Interfaces (Typ)) then
- Iface_Elmt := First_Elmt (Interfaces (Typ));
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
-
- pragma Assert (Is_Interface (Iface));
-
- if not Contain_Interface (Iface, Ifaces) then
- Append_Elmt (Iface, Ifaces);
- Collect_Implemented_Interfaces (Iface, Ifaces);
- end if;
-
- Next_Elmt (Iface_Elmt);
- end loop;
- end if;
- end Collect_Implemented_Interfaces;
-
- -- Start of processing for Process_Full_View
-
- begin
- -- First some sanity checks that must be done after semantic
- -- decoration of the full view and thus cannot be placed with other
- -- similar checks in Find_Type_Name
-
- if not Is_Limited_Type (Priv_T)
- and then (Is_Limited_Type (Full_T)
- or else Is_Limited_Composite (Full_T))
- then
- if In_Instance then
- null;
- else
- Error_Msg_N
- ("completion of nonlimited type cannot be limited", Full_T);
- Explain_Limited_Type (Full_T, Full_T);
- end if;
-
- elsif Is_Abstract_Type (Full_T)
- and then not Is_Abstract_Type (Priv_T)
- then
- Error_Msg_N
- ("completion of nonabstract type cannot be abstract", Full_T);
-
- elsif Is_Tagged_Type (Priv_T)
- and then Is_Limited_Type (Priv_T)
- and then not Is_Limited_Type (Full_T)
- then
- -- If pragma CPP_Class was applied to the private declaration
- -- propagate the limitedness to the full-view
-
- if Is_CPP_Class (Priv_T) then
- Set_Is_Limited_Record (Full_T);
-
- -- GNAT allow its own definition of Limited_Controlled to disobey
- -- this rule in order in ease the implementation. This test is safe
- -- because Root_Controlled is defined in a child of System that
- -- normal programs are not supposed to use.
-
- elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then
- Set_Is_Limited_Composite (Full_T);
- else
- Error_Msg_N
- ("completion of limited tagged type must be limited", Full_T);
- end if;
-
- elsif Is_Generic_Type (Priv_T) then
- Error_Msg_N ("generic type cannot have a completion", Full_T);
- end if;
-
- -- Check that ancestor interfaces of private and full views are
- -- consistent. We omit this check for synchronized types because
- -- they are performed on the corresponding record type when frozen.
-
- if Ada_Version >= Ada_2005
- and then Is_Tagged_Type (Priv_T)
- and then Is_Tagged_Type (Full_T)
- and then not Is_Concurrent_Type (Full_T)
- then
- declare
- Iface : Entity_Id;
- Priv_T_Ifaces : constant Elist_Id := New_Elmt_List;
- Full_T_Ifaces : constant Elist_Id := New_Elmt_List;
-
- begin
- Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
- Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
-
- -- Ada 2005 (AI-251): The partial view shall be a descendant of
- -- an interface type if and only if the full type is descendant
- -- of the interface type (AARM 7.3 (7.3/2)).
-
- Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
-
- if Present (Iface) then
- Error_Msg_NE
- ("interface in partial view& not implemented by full type "
- & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
- end if;
-
- Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
-
- if Present (Iface) then
- Error_Msg_NE
- ("interface & not implemented by partial view "
- & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
- end if;
- end;
- end if;
-
- if 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);
-
- -- The full view of a private extension may have been transformed
- -- into an unconstrained derived type declaration and a subtype
- -- declaration (see build_derived_record_type for details).
-
- 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;
-
- -- Check that the parent type of the full type is a descendant of
- -- the ancestor subtype given in the private extension. If either
- -- entity has an Etype equal to Any_Type then we had some previous
- -- error situation [7.3(8)].
-
- if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
- return;
-
- -- Ada 2005 (AI-251): Interfaces in the full type can be given in
- -- any order. Therefore we don't have to check that its parent must
- -- be a descendant of the parent of the private type declaration.
-
- elsif Is_Interface (Priv_Parent)
- and then Is_Interface (Full_Parent)
- then
- null;
-
- -- Ada 2005 (AI-251): If the parent of the private type declaration
- -- is an interface there is no need to check that it is an ancestor
- -- of the associated full type declaration. The required tests for
- -- this case are performed by Build_Derived_Record_Type.
-
- elsif not Is_Interface (Base_Type (Priv_Parent))
- and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
- then
- Error_Msg_N
- ("parent of full type must descend from parent"
- & " of private extension", Full_Indic);
-
- -- First check a formal restriction, and then proceed with checking
- -- Ada rules. Since the formal restriction is not a serious error, we
- -- don't prevent further error detection for this check, hence the
- -- ELSE.
-
- else
-
- -- In formal mode, when completing a private extension the type
- -- named in the private part must be exactly the same as that
- -- named in the visible part.
-
- if Priv_Parent /= Full_Parent then
- Error_Msg_Name_1 := Chars (Priv_Parent);
- Check_SPARK_Restriction ("% expected", Full_Indic);
- end if;
-
- -- Check the rules of 7.3(10): if the private extension inherits
- -- known discriminants, then the full type must also inherit those
- -- discriminants from the same (ancestor) type, and the parent
- -- subtype of the full type must be constrained if and only if
- -- the ancestor subtype of the private extension is constrained.
-
- if No (Discriminant_Specifications (Parent (Priv_T)))
- and then not Has_Unknown_Discriminants (Priv_T)
- and then Has_Discriminants (Base_Type (Priv_Parent))
- then
- declare
- Priv_Indic : constant Node_Id :=
- Subtype_Indication (Parent (Priv_T));
-
- 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;
-
- -- Check the rules of 7.3(12): if a partial view has neither
- -- known or unknown discriminants, then the full type
- -- declaration shall define a definite subtype.
-
- elsif 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;
-
- -- ??????? Do we implement the following properly ?????
- -- If the ancestor subtype of a private extension has constrained
- -- discriminants, then the parent subtype of the full view shall
- -- impose a statically matching constraint on those discriminants
- -- [7.3(13)].
- end if;
-
- else
- -- For untagged types, verify that a type without discriminants is
- -- not completed with an unconstrained type. A separate error message
- -- is produced if the full type has defaulted discriminants.
-
- if not Is_Indefinite_Subtype (Priv_T)
- and then Is_Indefinite_Subtype (Full_T)
- then
- Error_Msg_Sloc := Sloc (Parent (Priv_T));
- Error_Msg_NE
- ("full view of& not compatible with declaration#",
- Full_T, Priv_T);
-
- if not Is_Tagged_Type (Full_T) then
- Error_Msg_N
- ("\one is constrained, the other unconstrained", Full_T);
- end if;
- end if;
- end if;
-
- -- AI-419: verify that the use of "limited" is consistent
-
- declare
- Orig_Decl : constant Node_Id := Original_Node (N);
-
- begin
- if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
- and then not Limited_Present (Parent (Priv_T))
- and then not Synchronized_Present (Parent (Priv_T))
- and then Nkind (Orig_Decl) = N_Full_Type_Declaration
- and then Nkind
- (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition
- and then Limited_Present (Type_Definition (Orig_Decl))
- then
- Error_Msg_N
- ("full view of non-limited extension cannot be limited", N);
- end if;
- end;
-
- -- Ada 2005 (AI-443): A synchronized private extension must be
- -- completed by a task or protected type.
-
- if Ada_Version >= Ada_2005
- and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
- and then Synchronized_Present (Parent (Priv_T))
- and then not Is_Concurrent_Type (Full_T)
- then
- Error_Msg_N ("full view of synchronized extension must " &
- "be synchronized type", N);
- end if;
-
- -- Ada 2005 AI-363: if the full view has discriminants with
- -- defaults, it is illegal to declare constrained access subtypes
- -- whose designated type is the current type. This allows objects
- -- of the type that are declared in the heap to be unconstrained.
-
- if not Has_Unknown_Discriminants (Priv_T)
- and then not Has_Discriminants (Priv_T)
- and then Has_Discriminants (Full_T)
- and then
- Present (Discriminant_Default_Value (First_Discriminant (Full_T)))
- then
- Set_Has_Constrained_Partial_View (Full_T);
- Set_Has_Constrained_Partial_View (Priv_T);
- end if;
+ begin
+ -- Abstract interfaces are only associated with tagged record types
- -- Create a full declaration for all its subtypes recorded in
- -- Private_Dependents and swap them similarly to the base type. These
- -- are subtypes that have been define before the full declaration of
- -- the private type. We also swap the entry in Private_Dependents list
- -- so we can properly restore the private view on exit from the scope.
+ if not Is_Tagged_Type (Typ) or else not Is_Record_Type (Typ) then
+ return;
+ end if;
- declare
- Priv_Elmt : Elmt_Id;
- Priv_Scop : Entity_Id;
- Priv : Entity_Id;
- Full : Entity_Id;
+ -- Recursively climb to the ancestors
- begin
- Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
- while Present (Priv_Elmt) loop
- Priv := Node (Priv_Elmt);
- Priv_Scop := Scope (Priv);
+ if Etype (Typ) /= Typ
- if Ekind_In (Priv, E_Private_Subtype,
- E_Limited_Private_Subtype,
- E_Record_Subtype_With_Private)
- then
- Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
- Set_Is_Itype (Full);
- Set_Parent (Full, Parent (Priv));
- Set_Associated_Node_For_Itype (Full, N);
+ -- Protect the frontend against wrong cyclic declarations like:
- -- Now we need to complete the private subtype, but since the
- -- base type has already been swapped, we must also swap the
- -- subtypes (and thus, reverse the arguments in the call to
- -- Complete_Private_Subtype). Also note that we may need to
- -- re-establish the scope of the private subtype.
+ -- type B is new A with private;
+ -- type C is new A with private;
+ -- private
+ -- type B is new C with null record;
+ -- type C is new B with null record;
- Copy_And_Swap (Priv, Full);
+ and then Etype (Typ) /= Priv_T
+ and then Etype (Typ) /= Full_T
+ then
+ -- Keep separate the management of private type declarations
- if not In_Open_Scopes (Priv_Scop) then
- Push_Scope (Priv_Scop);
+ if Ekind (Typ) = E_Record_Type_With_Private then
- else
- -- Reset Priv_Scop to Empty to indicate no scope was pushed
+ -- Handle the following illegal usage:
+ -- type Private_Type is tagged private;
+ -- private
+ -- type Private_Type is new Type_Implementing_Iface;
- Priv_Scop := Empty;
+ if Present (Full_View (Typ))
+ and then Etype (Typ) /= Full_View (Typ)
+ then
+ if Is_Interface (Etype (Typ)) then
+ Append_Unique_Elmt (Etype (Typ), Ifaces);
+ end if;
+
+ Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
end if;
- Complete_Private_Subtype (Full, Priv, Full_T, N);
+ -- Non-private types
- if Present (Priv_Scop) then
- Pop_Scope;
+ else
+ if Is_Interface (Etype (Typ)) then
+ Append_Unique_Elmt (Etype (Typ), Ifaces);
end if;
- Replace_Elmt (Priv_Elmt, Full);
+ Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
end if;
+ end if;
- Next_Elmt (Priv_Elmt);
- end loop;
- end;
+ -- Handle entities in the list of abstract interfaces
- -- If the private view was tagged, copy the new primitive operations
- -- from the private view to the full view.
+ if Present (Interfaces (Typ)) then
+ Iface_Elmt := First_Elmt (Interfaces (Typ));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
- if Is_Tagged_Type (Full_T) then
- declare
- Disp_Typ : Entity_Id;
- Full_List : Elist_Id;
- Prim : Entity_Id;
- Prim_Elmt : Elmt_Id;
- Priv_List : Elist_Id;
+ pragma Assert (Is_Interface (Iface));
- function Contains
- (E : Entity_Id;
- L : Elist_Id) return Boolean;
- -- Determine whether list L contains element E
+ if not Contain_Interface (Iface, Ifaces) then
+ Append_Elmt (Iface, Ifaces);
+ Collect_Implemented_Interfaces (Iface, Ifaces);
+ end if;
- --------------
- -- Contains --
- --------------
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+ end Collect_Implemented_Interfaces;
- function Contains
- (E : Entity_Id;
- L : Elist_Id) return Boolean
- is
- List_Elmt : Elmt_Id;
+ -- Local variables
- begin
- List_Elmt := First_Elmt (L);
- while Present (List_Elmt) loop
- if Node (List_Elmt) = E then
- return True;
- end if;
+ Full_Indic : Node_Id;
+ Full_Parent : Entity_Id;
+ Priv_Parent : Entity_Id;
- Next_Elmt (List_Elmt);
- end loop;
+ -- Start of processing for Process_Full_View
- return False;
- end Contains;
+ begin
+ -- First some sanity checks that must be done after semantic
+ -- decoration of the full view and thus cannot be placed with other
+ -- similar checks in Find_Type_Name
- -- Start of processing
+ if not Is_Limited_Type (Priv_T)
+ and then (Is_Limited_Type (Full_T)
+ or else Is_Limited_Composite (Full_T))
+ then
+ if In_Instance then
+ null;
+ else
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", Full_T);
+ Explain_Limited_Type (Full_T, Full_T);
+ end if;
- begin
- if Is_Tagged_Type (Priv_T) then
- Priv_List := Primitive_Operations (Priv_T);
- Prim_Elmt := First_Elmt (Priv_List);
+ elsif Is_Abstract_Type (Full_T)
+ and then not Is_Abstract_Type (Priv_T)
+ then
+ Error_Msg_N
+ ("completion of nonabstract type cannot be abstract", Full_T);
- -- In the case of a concurrent type completing a private tagged
- -- type, primitives may have been declared in between the two
- -- views. These subprograms need to be wrapped the same way
- -- entries and protected procedures are handled because they
- -- cannot be directly shared by the two views.
+ elsif Is_Tagged_Type (Priv_T)
+ and then Is_Limited_Type (Priv_T)
+ and then not Is_Limited_Type (Full_T)
+ then
+ -- If pragma CPP_Class was applied to the private declaration
+ -- propagate the limitedness to the full-view
- if Is_Concurrent_Type (Full_T) then
- declare
- Conc_Typ : constant Entity_Id :=
- Corresponding_Record_Type (Full_T);
- Curr_Nod : Node_Id := Parent (Conc_Typ);
- Wrap_Spec : Node_Id;
+ if Is_CPP_Class (Priv_T) then
+ Set_Is_Limited_Record (Full_T);
- begin
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ -- GNAT allow its own definition of Limited_Controlled to disobey
+ -- this rule in order in ease the implementation. This test is safe
+ -- because Root_Controlled is defined in a child of System that
+ -- normal programs are not supposed to use.
- if Comes_From_Source (Prim)
- and then not Is_Abstract_Subprogram (Prim)
- then
- Wrap_Spec :=
- Make_Subprogram_Declaration (Sloc (Prim),
- Specification =>
- Build_Wrapper_Spec
- (Subp_Id => Prim,
- Obj_Typ => Conc_Typ,
- Formals =>
- Parameter_Specifications (
- Parent (Prim))));
+ elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then
+ Set_Is_Limited_Composite (Full_T);
+ else
+ Error_Msg_N
+ ("completion of limited tagged type must be limited", Full_T);
+ end if;
- Insert_After (Curr_Nod, Wrap_Spec);
- Curr_Nod := Wrap_Spec;
+ elsif Is_Generic_Type (Priv_T) then
+ Error_Msg_N ("generic type cannot have a completion", Full_T);
+ end if;
- Analyze (Wrap_Spec);
- end if;
+ -- Check that ancestor interfaces of private and full views are
+ -- consistent. We omit this check for synchronized types because
+ -- they are performed on the corresponding record type when frozen.
- Next_Elmt (Prim_Elmt);
- end loop;
+ if Ada_Version >= Ada_2005
+ and then Is_Tagged_Type (Priv_T)
+ and then Is_Tagged_Type (Full_T)
+ and then not Is_Concurrent_Type (Full_T)
+ then
+ declare
+ Iface : Entity_Id;
+ Priv_T_Ifaces : constant Elist_Id := New_Elmt_List;
+ Full_T_Ifaces : constant Elist_Id := New_Elmt_List;
- return;
- end;
+ begin
+ Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
+ Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
- -- For non-concurrent types, transfer explicit primitives, but
- -- omit those inherited from the parent of the private view
- -- since they will be re-inherited later on.
+ -- Ada 2005 (AI-251): The partial view shall be a descendant of
+ -- an interface type if and only if the full type is descendant
+ -- of the interface type (AARM 7.3 (7.3/2)).
- else
- Full_List := Primitive_Operations (Full_T);
+ Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
- while Present (Prim_Elmt) loop
- Prim := Node (Prim_Elmt);
+ if Present (Iface) then
+ Error_Msg_NE
+ ("interface in partial view& not implemented by full type "
+ & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
+ end if;
+
+ Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
+
+ if Present (Iface) then
+ Error_Msg_NE
+ ("interface & not implemented by partial view "
+ & "(RM-2005 7.3 (7.3/2))", Full_T, Iface);
+ end if;
+ end;
+ end if;
- if Comes_From_Source (Prim)
- and then not Contains (Prim, Full_List)
- then
- Append_Elmt (Prim, Full_List);
- 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);
- Next_Elmt (Prim_Elmt);
- end loop;
- end if;
+ -- The full view of a private extension may have been transformed
+ -- into an unconstrained derived type declaration and a subtype
+ -- declaration (see build_derived_record_type for details).
- -- Untagged private view
+ 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;
- else
- Full_List := Primitive_Operations (Full_T);
+ -- Check that the parent type of the full type is a descendant of
+ -- the ancestor subtype given in the private extension. If either
+ -- entity has an Etype equal to Any_Type then we had some previous
+ -- error situation [7.3(8)].
- -- In this case the partial view is untagged, so here we locate
- -- all of the earlier primitives that need to be treated as
- -- dispatching (those that appear between the two views). Note
- -- that these additional operations must all be new operations
- -- (any earlier operations that override inherited operations
- -- of the full view will already have been inserted in the
- -- primitives list, marked by Check_Operation_From_Private_View
- -- as dispatching. Note that implicit "/=" operators are
- -- excluded from being added to the primitives list since they
- -- shouldn't be treated as dispatching (tagged "/=" is handled
- -- specially).
+ if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
+ return;
- Prim := Next_Entity (Full_T);
- while Present (Prim) and then Prim /= Priv_T loop
- if Ekind_In (Prim, E_Procedure, E_Function) then
- Disp_Typ := Find_Dispatching_Type (Prim);
+ -- Ada 2005 (AI-251): Interfaces in the full type can be given in
+ -- any order. Therefore we don't have to check that its parent must
+ -- be a descendant of the parent of the private type declaration.
- if Disp_Typ = Full_T
- and then (Chars (Prim) /= Name_Op_Ne
- or else Comes_From_Source (Prim))
- then
- Check_Controlling_Formals (Full_T, Prim);
+ elsif Is_Interface (Priv_Parent)
+ and then Is_Interface (Full_Parent)
+ then
+ null;
- 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;
+ -- Ada 2005 (AI-251): If the parent of the private type declaration
+ -- is an interface there is no need to check that it is an ancestor
+ -- of the associated full type declaration. The required tests for
+ -- this case are performed by Build_Derived_Record_Type.
- elsif Is_Dispatching_Operation (Prim)
- and then Disp_Typ /= Full_T
- then
+ elsif not Is_Interface (Base_Type (Priv_Parent))
+ and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
+ then
+ Error_Msg_N
+ ("parent of full type must descend from parent"
+ & " of private extension", Full_Indic);
- -- Verify that it is not otherwise controlled by a
- -- formal or a return value of type T.
+ -- First check a formal restriction, and then proceed with checking
+ -- Ada rules. Since the formal restriction is not a serious error, we
+ -- don't prevent further error detection for this check, hence the
+ -- ELSE.
- Check_Controlling_Formals (Disp_Typ, Prim);
- end if;
- end if;
+ else
+ -- In formal mode, when completing a private extension the type
+ -- named in the private part must be exactly the same as that
+ -- named in the visible part.
- Next_Entity (Prim);
- end loop;
+ if Priv_Parent /= Full_Parent then
+ Error_Msg_Name_1 := Chars (Priv_Parent);
+ Check_SPARK_05_Restriction ("% expected", Full_Indic);
end if;
- -- For the tagged case, the two views can share the same primitive
- -- operations list and the same class-wide type. Update attributes
- -- of the class-wide type which depend on the full declaration.
-
- if Is_Tagged_Type (Priv_T) then
- Set_Direct_Primitive_Operations (Priv_T, Full_List);
- Set_Class_Wide_Type
- (Base_Type (Full_T), Class_Wide_Type (Priv_T));
+ -- Check the rules of 7.3(10): if the private extension inherits
+ -- known discriminants, then the full type must also inherit those
+ -- discriminants from the same (ancestor) type, and the parent
+ -- subtype of the full type must be constrained if and only if
+ -- the ancestor subtype of the private extension is constrained.
- Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
- Set_Has_Protected
- (Class_Wide_Type (Priv_T), Has_Protected (Full_T));
- end if;
- end;
- end if;
+ if No (Discriminant_Specifications (Parent (Priv_T)))
+ and then not Has_Unknown_Discriminants (Priv_T)
+ and then Has_Discriminants (Base_Type (Priv_Parent))
+ then
+ declare
+ Priv_Indic : constant Node_Id :=
+ Subtype_Indication (Parent (Priv_T));
- -- Ada 2005 AI 161: Check preelaborable initialization consistency
+ Priv_Constr : constant Boolean :=
+ Is_Constrained (Priv_Parent)
+ or else
+ Nkind (Priv_Indic) = N_Subtype_Indication
+ or else
+ Is_Constrained (Entity (Priv_Indic));
- if Known_To_Have_Preelab_Init (Priv_T) then
+ Full_Constr : constant Boolean :=
+ Is_Constrained (Full_Parent)
+ or else
+ Nkind (Full_Indic) = N_Subtype_Indication
+ or else
+ Is_Constrained (Entity (Full_Indic));
- -- Case where there is a pragma Preelaborable_Initialization. We
- -- always allow this in predefined units, which is cheating a bit,
- -- but it means we don't have to struggle to meet the requirements in
- -- the RM for having Preelaborable Initialization. Otherwise we
- -- require that the type meets the RM rules. But we can't check that
- -- yet, because of the rule about overriding Initialize, so we simply
- -- set a flag that will be checked at freeze time.
+ Priv_Discr : Entity_Id;
+ Full_Discr : Entity_Id;
- if not In_Predefined_Unit (Full_T) then
- Set_Must_Have_Preelab_Init (Full_T);
- end if;
- end if;
+ 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;
- -- If pragma CPP_Class was applied to the private type declaration,
- -- propagate it now to the full type declaration.
+ Next_Discriminant (Priv_Discr);
+ Next_Discriminant (Full_Discr);
+ end loop;
- if Is_CPP_Class (Priv_T) then
- Set_Is_CPP_Class (Full_T);
- Set_Convention (Full_T, Convention_CPP);
+ 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);
- -- Check that components of imported CPP types do not have default
- -- expressions.
+ elsif Priv_Constr and then not Full_Constr then
+ Error_Msg_N
+ ("parent subtype of full type must be constrained",
+ Full_Indic);
- Check_CPP_Type_Has_No_Defaults (Full_T);
- end if;
+ elsif Full_Constr and then not Priv_Constr then
+ Error_Msg_N
+ ("parent subtype of full type must be unconstrained",
+ Full_Indic);
+ end if;
+ end;
- -- If the private view has user specified stream attributes, then so has
- -- the full view.
+ -- Check the rules of 7.3(12): if a partial view has neither
+ -- known or unknown discriminants, then the full type
+ -- declaration shall define a definite subtype.
- -- Why the test, how could these flags be already set in Full_T ???
+ elsif not Has_Unknown_Discriminants (Priv_T)
+ and then not Has_Discriminants (Priv_T)
+ and then not Is_Constrained (Full_T)
+ then
+ Error_Msg_N
+ ("full view must define a constrained type if partial view"
+ & " has no discriminants", Full_T);
+ end if;
- if Has_Specified_Stream_Read (Priv_T) then
- Set_Has_Specified_Stream_Read (Full_T);
- end if;
+ -- ??????? Do we implement the following properly ?????
+ -- If the ancestor subtype of a private extension has constrained
+ -- discriminants, then the parent subtype of the full view shall
+ -- impose a statically matching constraint on those discriminants
+ -- [7.3(13)].
+ end if;
- if Has_Specified_Stream_Write (Priv_T) then
- Set_Has_Specified_Stream_Write (Full_T);
- end if;
+ else
+ -- For untagged types, verify that a type without discriminants is
+ -- not completed with an unconstrained type. A separate error message
+ -- is produced if the full type has defaulted discriminants.
- if Has_Specified_Stream_Input (Priv_T) then
- Set_Has_Specified_Stream_Input (Full_T);
- end if;
+ if not Is_Indefinite_Subtype (Priv_T)
+ and then Is_Indefinite_Subtype (Full_T)
+ then
+ Error_Msg_Sloc := Sloc (Parent (Priv_T));
+ Error_Msg_NE
+ ("full view of& not compatible with declaration#",
+ Full_T, Priv_T);
- if Has_Specified_Stream_Output (Priv_T) then
- Set_Has_Specified_Stream_Output (Full_T);
+ if not Is_Tagged_Type (Full_T) then
+ Error_Msg_N
+ ("\one is constrained, the other unconstrained", Full_T);
+ end if;
+ end if;
end if;
- -- Propagate invariants to full type
+ -- AI-419: verify that the use of "limited" is consistent
- if Has_Invariants (Priv_T) then
- Set_Has_Invariants (Full_T);
- Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T));
- end if;
+ declare
+ Orig_Decl : constant Node_Id := Original_Node (N);
- if Has_Inheritable_Invariants (Priv_T) then
- Set_Has_Inheritable_Invariants (Full_T);
- end if;
+ begin
+ if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
+ and then Nkind (Orig_Decl) = N_Full_Type_Declaration
+ and then Nkind
+ (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition
+ then
+ if not Limited_Present (Parent (Priv_T))
+ and then not Synchronized_Present (Parent (Priv_T))
+ and then Limited_Present (Type_Definition (Orig_Decl))
+ then
+ Error_Msg_N
+ ("full view of non-limited extension cannot be limited", N);
- -- Propagate predicates to full type, and predicate function if already
- -- defined. It is not clear that this can actually happen? the partial
- -- view cannot be frozen yet, and the predicate function has not been
- -- built. Still it is a cheap check and seems safer to make it.
+ -- Conversely, if the partial view carries the limited keyword,
+ -- the full view must as well, even if it may be redundant.
- if Has_Predicates (Priv_T) then
- if Present (Predicate_Function (Priv_T)) then
- Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
+ elsif Limited_Present (Parent (Priv_T))
+ and then not Limited_Present (Type_Definition (Orig_Decl))
+ then
+ Error_Msg_N
+ ("full view of limited extension must be explicitly limited",
+ N);
+ end if;
end if;
+ end;
- Set_Has_Predicates (Full_T);
- end if;
- end Process_Full_View;
-
- -----------------------------------
- -- Process_Incomplete_Dependents --
- -----------------------------------
+ -- Ada 2005 (AI-443): A synchronized private extension must be
+ -- completed by a task or protected type.
- 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;
+ if Ada_Version >= Ada_2005
+ and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
+ and then Synchronized_Present (Parent (Priv_T))
+ and then not Is_Concurrent_Type (Full_T)
+ then
+ Error_Msg_N ("full view of synchronized extension must " &
+ "be synchronized type", N);
+ end if;
- Disc_Constraint : Elist_Id;
+ -- Ada 2005 AI-363: if the full view has discriminants with
+ -- defaults, it is illegal to declare constrained access subtypes
+ -- whose designated type is the current type. This allows objects
+ -- of the type that are declared in the heap to be unconstrained.
- begin
- if No (Private_Dependents (Inc_T)) then
- return;
+ if not Has_Unknown_Discriminants (Priv_T)
+ and then not Has_Discriminants (Priv_T)
+ and then Has_Discriminants (Full_T)
+ and then
+ Present (Discriminant_Default_Value (First_Discriminant (Full_T)))
+ then
+ Set_Has_Constrained_Partial_View (Full_T);
+ Set_Has_Constrained_Partial_View (Priv_T);
end if;
- -- Itypes that may be generated by the completion of an incomplete
- -- subtype are not used by the back-end and not attached to the tree.
- -- They are created only for constraint-checking purposes.
+ -- Create a full declaration for all its subtypes recorded in
+ -- Private_Dependents and swap them similarly to the base type. These
+ -- are subtypes that have been define before the full declaration of
+ -- the private type. We also swap the entry in Private_Dependents list
+ -- so we can properly restore the private view on exit from the scope.
- Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
- while Present (Inc_Elmt) loop
- Priv_Dep := Node (Inc_Elmt);
+ declare
+ Priv_Elmt : Elmt_Id;
+ Priv_Scop : Entity_Id;
+ Priv : Entity_Id;
+ Full : Entity_Id;
- if Ekind (Priv_Dep) = E_Subprogram_Type then
+ begin
+ Priv_Elmt := First_Elmt (Private_Dependents (Priv_T));
+ while Present (Priv_Elmt) loop
+ Priv := Node (Priv_Elmt);
+ Priv_Scop := Scope (Priv);
- -- An Access_To_Subprogram type may have a return type or a
- -- parameter type that is incomplete. Replace with the full view.
+ if Ekind_In (Priv, E_Private_Subtype,
+ E_Limited_Private_Subtype,
+ E_Record_Subtype_With_Private)
+ then
+ Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
+ Set_Is_Itype (Full);
+ Set_Parent (Full, Parent (Priv));
+ Set_Associated_Node_For_Itype (Full, N);
- if Etype (Priv_Dep) = Inc_T then
- Set_Etype (Priv_Dep, Full_T);
- end if;
+ -- Now we need to complete the private subtype, but since the
+ -- base type has already been swapped, we must also swap the
+ -- subtypes (and thus, reverse the arguments in the call to
+ -- Complete_Private_Subtype). Also note that we may need to
+ -- re-establish the scope of the private subtype.
- declare
- Formal : Entity_Id;
+ Copy_And_Swap (Priv, Full);
- begin
- Formal := First_Formal (Priv_Dep);
- while Present (Formal) loop
- if Etype (Formal) = Inc_T then
- Set_Etype (Formal, Full_T);
- end if;
+ if not In_Open_Scopes (Priv_Scop) then
+ Push_Scope (Priv_Scop);
- Next_Formal (Formal);
- end loop;
- end;
+ else
+ -- Reset Priv_Scop to Empty to indicate no scope was pushed
- elsif Is_Overloadable (Priv_Dep) then
+ Priv_Scop := Empty;
+ end if;
- -- If a subprogram in the incomplete dependents list is primitive
- -- for a tagged full type then mark it as a dispatching operation,
- -- check whether it overrides an inherited subprogram, and check
- -- restrictions on its controlling formals. Note that a protected
- -- operation is never dispatching: only its wrapper operation
- -- (which has convention Ada) is.
+ Complete_Private_Subtype (Full, Priv, Full_T, N);
- if Is_Tagged_Type (Full_T)
- and then Is_Primitive (Priv_Dep)
- and then Convention (Priv_Dep) /= Convention_Protected
- then
- Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
- Set_Is_Dispatching_Operation (Priv_Dep);
- Check_Controlling_Formals (Full_T, Priv_Dep);
- end if;
+ if Present (Priv_Scop) then
+ Pop_Scope;
+ end if;
- elsif Ekind (Priv_Dep) = E_Subprogram_Body then
+ Replace_Elmt (Priv_Elmt, Full);
+ end if;
- -- Can happen during processing of a body before the completion
- -- of a TA type. Ignore, because spec is also on dependent list.
+ Next_Elmt (Priv_Elmt);
+ end loop;
+ end;
- return;
+ -- If the private view was tagged, copy the new primitive operations
+ -- from the private view to the full view.
- -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a
- -- corresponding subtype of the full view.
+ if Is_Tagged_Type (Full_T) then
+ declare
+ Disp_Typ : Entity_Id;
+ Full_List : Elist_Id;
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Priv_List : Elist_Id;
- elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then
- Set_Subtype_Indication
- (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep)));
- Set_Etype (Priv_Dep, Full_T);
- Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
- Set_Analyzed (Parent (Priv_Dep), False);
+ function Contains
+ (E : Entity_Id;
+ L : Elist_Id) return Boolean;
+ -- Determine whether list L contains element E
- -- Reanalyze the declaration, suppressing the call to
- -- Enter_Name to avoid duplicate names.
+ --------------
+ -- Contains --
+ --------------
- Analyze_Subtype_Declaration
- (N => Parent (Priv_Dep),
- Skip => True);
+ function Contains
+ (E : Entity_Id;
+ L : Elist_Id) return Boolean
+ is
+ List_Elmt : Elmt_Id;
- -- Dependent is a subtype
+ begin
+ List_Elmt := First_Elmt (L);
+ while Present (List_Elmt) loop
+ if Node (List_Elmt) = E then
+ return True;
+ end if;
- else
- -- We build a new subtype indication using the full view of the
- -- incomplete parent. The discriminant constraints have been
- -- elaborated already at the point of the subtype declaration.
+ Next_Elmt (List_Elmt);
+ end loop;
- New_Subt := Create_Itype (E_Void, N);
+ return False;
+ end Contains;
- if Has_Discriminants (Full_T) then
- Disc_Constraint := Discriminant_Constraint (Priv_Dep);
- else
- Disc_Constraint := No_Elist;
- end if;
+ -- Start of processing
- Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
- Set_Full_View (Priv_Dep, New_Subt);
- end if;
+ begin
+ if Is_Tagged_Type (Priv_T) then
+ Priv_List := Primitive_Operations (Priv_T);
+ Prim_Elmt := First_Elmt (Priv_List);
- Next_Elmt (Inc_Elmt);
- end loop;
- end Process_Incomplete_Dependents;
+ -- In the case of a concurrent type completing a private tagged
+ -- type, primitives may have been declared in between the two
+ -- views. These subprograms need to be wrapped the same way
+ -- entries and protected procedures are handled because they
+ -- cannot be directly shared by the two views.
- --------------------------------
- -- Process_Range_Expr_In_Decl --
- --------------------------------
+ if Is_Concurrent_Type (Full_T) then
+ declare
+ Conc_Typ : constant Entity_Id :=
+ Corresponding_Record_Type (Full_T);
+ Curr_Nod : Node_Id := Parent (Conc_Typ);
+ Wrap_Spec : Node_Id;
- procedure Process_Range_Expr_In_Decl
- (R : Node_Id;
- T : Entity_Id;
- Subtyp : Entity_Id := Empty;
- Check_List : List_Id := Empty_List;
- R_Check_Off : Boolean := False;
- In_Iter_Schm : Boolean := False)
- is
- Lo, Hi : Node_Id;
- R_Checks : Check_Result;
- Insert_Node : Node_Id;
- Def_Id : Entity_Id;
+ begin
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- begin
- Analyze_And_Resolve (R, Base_Type (T));
+ if Comes_From_Source (Prim)
+ and then not Is_Abstract_Subprogram (Prim)
+ then
+ Wrap_Spec :=
+ Make_Subprogram_Declaration (Sloc (Prim),
+ Specification =>
+ Build_Wrapper_Spec
+ (Subp_Id => Prim,
+ Obj_Typ => Conc_Typ,
+ Formals =>
+ Parameter_Specifications (
+ Parent (Prim))));
- if Nkind (R) = N_Range then
+ Insert_After (Curr_Nod, Wrap_Spec);
+ Curr_Nod := Wrap_Spec;
- -- In SPARK, all ranges should be static, with the exception of the
- -- discrete type definition of a loop parameter specification.
+ Analyze (Wrap_Spec);
+ end if;
- if not In_Iter_Schm
- and then not Is_OK_Static_Range (R)
- then
- Check_SPARK_Restriction ("range should be static", R);
- end if;
+ Next_Elmt (Prim_Elmt);
+ end loop;
- Lo := Low_Bound (R);
- Hi := High_Bound (R);
+ return;
+ end;
- -- We need to ensure validity of the bounds here, because if we
- -- go ahead and do the expansion, then the expanded code will get
- -- analyzed with range checks suppressed and we miss the check.
- -- Validity checks on the range of a quantified expression are
- -- delayed until the construct is transformed into a loop.
+ -- For non-concurrent types, transfer explicit primitives, but
+ -- omit those inherited from the parent of the private view
+ -- since they will be re-inherited later on.
- if Nkind (Parent (R)) /= N_Loop_Parameter_Specification
- or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression
- then
- Validity_Check_Range (R);
- end if;
+ else
+ Full_List := Primitive_Operations (Full_T);
- -- If there were errors in the declaration, try and patch up some
- -- common mistakes in the bounds. The cases handled are literals
- -- which are Integer where the expected type is Real and vice versa.
- -- These corrections allow the compilation process to proceed further
- -- along since some basic assumptions of the format of the bounds
- -- are guaranteed.
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
- 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))));
+ if Comes_From_Source (Prim)
+ and then not Contains (Prim, Full_List)
+ then
+ Append_Elmt (Prim, Full_List);
+ end if;
- elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
- Rewrite (Hi,
- Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
- 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))));
+ -- Untagged private view
- 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;
+ else
+ Full_List := Primitive_Operations (Full_T);
- Set_Etype (Lo, T);
- Set_Etype (Hi, T);
- end if;
+ -- In this case the partial view is untagged, so here we locate
+ -- all of the earlier primitives that need to be treated as
+ -- dispatching (those that appear between the two views). Note
+ -- that these additional operations must all be new operations
+ -- (any earlier operations that override inherited operations
+ -- of the full view will already have been inserted in the
+ -- primitives list, marked by Check_Operation_From_Private_View
+ -- as dispatching. Note that implicit "/=" operators are
+ -- excluded from being added to the primitives list since they
+ -- shouldn't be treated as dispatching (tagged "/=" is handled
+ -- specially).
- -- If the bounds of the range have been mistakenly given as string
- -- literals (perhaps in place of character literals), then an error
- -- has already been reported, but we rewrite the string literal as a
- -- bound of the range's type to avoid blowups in later processing
- -- that looks at static values.
+ Prim := Next_Entity (Full_T);
+ while Present (Prim) and then Prim /= Priv_T loop
+ if Ekind_In (Prim, E_Procedure, E_Function) then
+ Disp_Typ := Find_Dispatching_Type (Prim);
- if Nkind (Lo) = N_String_Literal then
- Rewrite (Lo,
- Make_Attribute_Reference (Sloc (Lo),
- Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (T, Sloc (Lo))));
- Analyze_And_Resolve (Lo);
- end if;
+ if Disp_Typ = Full_T
+ and then (Chars (Prim) /= Name_Op_Ne
+ or else Comes_From_Source (Prim))
+ then
+ Check_Controlling_Formals (Full_T, Prim);
- if Nkind (Hi) = N_String_Literal then
- Rewrite (Hi,
- Make_Attribute_Reference (Sloc (Hi),
- Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (T, Sloc (Hi))));
- Analyze_And_Resolve (Hi);
- end if;
+ if not Is_Dispatching_Operation (Prim) then
+ Append_Elmt (Prim, Full_List);
+ Set_Is_Dispatching_Operation (Prim, True);
+ Set_DT_Position_Value (Prim, No_Uint);
+ end if;
- -- If bounds aren't scalar at this point then exit, avoiding
- -- problems with further processing of the range in this procedure.
+ elsif Is_Dispatching_Operation (Prim)
+ and then Disp_Typ /= Full_T
+ then
- if not Is_Scalar_Type (Etype (Lo)) then
- return;
- end if;
+ -- Verify that it is not otherwise controlled by a
+ -- formal or a return value of type T.
- -- Resolve (actually Sem_Eval) has checked that the bounds are in
- -- then range of the base type. Here we check whether the bounds
- -- are in the range of the subtype itself. Note that if the bounds
- -- represent the null range the Constraint_Error exception should
- -- not be raised.
+ Check_Controlling_Formals (Disp_Typ, Prim);
+ end if;
+ end if;
- -- ??? The following code should be cleaned up as follows
+ Next_Entity (Prim);
+ end loop;
+ end if;
- -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
- -- is done in the call to Range_Check (R, T); below
+ -- For the tagged case, the two views can share the same primitive
+ -- operations list and the same class-wide type. Update attributes
+ -- of the class-wide type which depend on the full declaration.
- -- 2. The use of R_Check_Off should be investigated and possibly
- -- removed, this would clean up things a bit.
+ if Is_Tagged_Type (Priv_T) then
+ Set_Direct_Primitive_Operations (Priv_T, Full_List);
+ Set_Class_Wide_Type
+ (Base_Type (Full_T), Class_Wide_Type (Priv_T));
- if Is_Null_Range (Lo, Hi) then
- null;
+ Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
+ Set_Has_Protected
+ (Class_Wide_Type (Priv_T), Has_Protected (Full_T));
+ end if;
+ end;
+ end if;
- else
- -- Capture values of bounds and generate temporaries for them
- -- if needed, before applying checks, since checks may cause
- -- duplication of the expression without forcing evaluation.
+ -- Ada 2005 AI 161: Check preelaborable initialization consistency
- -- The forced evaluation removes side effects from expressions,
- -- which should occur also in GNATprove mode. Otherwise, we end up
- -- with unexpected insertions of actions at places where this is
- -- not supposed to occur, e.g. on default parameters of a call.
+ if Known_To_Have_Preelab_Init (Priv_T) then
- if Expander_Active or GNATprove_Mode then
+ -- Case where there is a pragma Preelaborable_Initialization. We
+ -- always allow this in predefined units, which is cheating a bit,
+ -- but it means we don't have to struggle to meet the requirements in
+ -- the RM for having Preelaborable Initialization. Otherwise we
+ -- require that the type meets the RM rules. But we can't check that
+ -- yet, because of the rule about overriding Initialize, so we simply
+ -- set a flag that will be checked at freeze time.
- -- If no subtype name, then just call Force_Evaluation to
- -- create declarations as needed to deal with side effects.
- -- Also ignore calls from within a record type, where we
- -- have possible scoping issues.
+ if not In_Predefined_Unit (Full_T) then
+ Set_Must_Have_Preelab_Init (Full_T);
+ end if;
+ end if;
- if No (Subtyp) or else Is_Record_Type (Current_Scope) then
- Force_Evaluation (Lo);
- Force_Evaluation (Hi);
+ -- If pragma CPP_Class was applied to the private type declaration,
+ -- propagate it now to the full type declaration.
- -- If a subtype is given, then we capture the bounds if they
- -- are not known at compile time, using constant identifiers
- -- xxx_FIRST and xxx_LAST where xxx is the name of the subtype.
+ if Is_CPP_Class (Priv_T) then
+ Set_Is_CPP_Class (Full_T);
+ Set_Convention (Full_T, Convention_CPP);
- -- Note: we do this transformation even if expansion is not
- -- active, and in particular we do it in GNATprove_Mode since
- -- the transformation is in general required to ensure that the
- -- resulting tree has proper Ada semantics.
+ -- Check that components of imported CPP types do not have default
+ -- expressions.
- -- Historical note: We used to just do Force_Evaluation calls
- -- in all cases, but it is better to capture the bounds with
- -- proper non-serialized names, since these will be accessed
- -- from other units, and hence may be public, and also we can
- -- then expand 'First and 'Last references to be references to
- -- these special names.
+ Check_CPP_Type_Has_No_Defaults (Full_T);
+ end if;
- else
- if not Compile_Time_Known_Value (Lo)
+ -- If the private view has user specified stream attributes, then so has
+ -- the full view.
- -- No need to capture bounds if they already are
- -- references to constants.
+ -- Why the test, how could these flags be already set in Full_T ???
- and then not (Is_Entity_Name (Lo)
- and then Is_Constant_Object (Entity (Lo)))
- then
- declare
- Loc : constant Source_Ptr := Sloc (Lo);
- Lov : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Chars (Subtyp), "_FIRST"));
- begin
- Insert_Action (R,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Lov,
- Object_Definition =>
- New_Occurrence_Of (Base_Type (T), Loc),
- Constant_Present => True,
- Expression => Relocate_Node (Lo)));
- Rewrite (Lo, New_Occurrence_Of (Lov, Loc));
- end;
- end if;
+ if Has_Specified_Stream_Read (Priv_T) then
+ Set_Has_Specified_Stream_Read (Full_T);
+ end if;
- if not Compile_Time_Known_Value (Hi)
- and then not (Is_Entity_Name (Hi)
- and then Is_Constant_Object (Entity (Hi)))
- then
- declare
- Loc : constant Source_Ptr := Sloc (Hi);
- Hiv : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Chars (Subtyp), "_LAST"));
- begin
- Insert_Action (R,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Hiv,
- Object_Definition =>
- New_Occurrence_Of (Base_Type (T), Loc),
- Constant_Present => True,
- Expression => Relocate_Node (Hi)));
- Rewrite (Hi, New_Occurrence_Of (Hiv, Loc));
- end;
- end if;
- end if;
- end if;
+ if Has_Specified_Stream_Write (Priv_T) then
+ Set_Has_Specified_Stream_Write (Full_T);
+ end if;
- -- We use a flag here instead of suppressing checks on the
- -- type because the type we check against isn't necessarily
- -- the place where we put the check.
+ if Has_Specified_Stream_Input (Priv_T) then
+ Set_Has_Specified_Stream_Input (Full_T);
+ end if;
- if not R_Check_Off then
- R_Checks := Get_Range_Checks (R, T);
+ if Has_Specified_Stream_Output (Priv_T) then
+ Set_Has_Specified_Stream_Output (Full_T);
+ end if;
- -- Look up tree to find an appropriate insertion point. We
- -- can't just use insert_actions because later processing
- -- depends on the insertion node. Prior to Ada 2012 the
- -- insertion point could only be a declaration or a loop, but
- -- quantified expressions can appear within any context in an
- -- expression, and the insertion point can be any statement,
- -- pragma, or declaration.
+ -- Propagate the attributes related to pragma Default_Initial_Condition
+ -- from the private to the full view. Note that both flags are mutually
+ -- exclusive.
- Insert_Node := Parent (R);
- while Present (Insert_Node) loop
- exit when
- Nkind (Insert_Node) in N_Declaration
- and then
- not Nkind_In
- (Insert_Node, N_Component_Declaration,
- N_Loop_Parameter_Specification,
- N_Function_Specification,
- N_Procedure_Specification);
+ if Has_Default_Init_Cond (Priv_T)
+ or else Has_Inherited_Default_Init_Cond (Priv_T)
+ then
+ Propagate_Default_Init_Cond_Attributes
+ (From_Typ => Priv_T,
+ To_Typ => Full_T,
+ Private_To_Full_View => True);
+
+ -- In the case where the full view is derived from another private type,
+ -- the attributes related to pragma Default_Initial_Condition must be
+ -- propagated from the full to the private view to maintain consistency
+ -- of views.
+
+ -- package Pack is
+ -- type Parent_Typ is private
+ -- with Default_Initial_Condition ...;
+ -- private
+ -- type Parent_Typ is ...;
+ -- end Pack;
+
+ -- with Pack; use Pack;
+ -- package Pack_2 is
+ -- type Deriv_Typ is private; -- must inherit
+ -- private
+ -- type Deriv_Typ is new Parent_Typ; -- must inherit
+ -- end Pack_2;
+
+ elsif Has_Default_Init_Cond (Full_T)
+ or else Has_Inherited_Default_Init_Cond (Full_T)
+ then
+ Propagate_Default_Init_Cond_Attributes
+ (From_Typ => Full_T,
+ To_Typ => Priv_T,
+ Private_To_Full_View => True);
+ end if;
- exit when Nkind (Insert_Node) in N_Later_Decl_Item
- or else Nkind (Insert_Node) in
- N_Statement_Other_Than_Procedure_Call
- or else Nkind_In (Insert_Node, N_Procedure_Call_Statement,
- N_Pragma);
+ -- Propagate the attributes related to pragma Ghost from the private to
+ -- the full view.
- Insert_Node := Parent (Insert_Node);
- end loop;
+ if Is_Ghost_Entity (Priv_T) then
+ Set_Is_Ghost_Entity (Full_T);
- -- Why would Type_Decl not be present??? Without this test,
- -- short regression tests fail.
+ -- The Ghost policy in effect at the point of declaration and at the
+ -- point of completion must match (SPARK RM 6.9(14)).
- if Present (Insert_Node) then
+ Check_Ghost_Completion (Priv_T, Full_T);
- -- Case of loop statement. Verify that the range is part
- -- of the subtype indication of the iteration scheme.
+ -- In the case where the private view of a tagged type lacks a parent
+ -- type and is subject to pragma Ghost, ensure that the parent type
+ -- specified by the full view is also Ghost (SPARK RM 6.9(9)).
- if Nkind (Insert_Node) = N_Loop_Statement then
- declare
- Indic : Node_Id;
+ if Is_Derived_Type (Full_T) then
+ Check_Ghost_Derivation (Full_T);
+ end if;
+ end if;
- begin
- Indic := Parent (R);
- while Present (Indic)
- and then Nkind (Indic) /= N_Subtype_Indication
- loop
- Indic := Parent (Indic);
- end loop;
+ -- Propagate invariants to full type
- if Present (Indic) then
- Def_Id := Etype (Subtype_Mark (Indic));
+ if Has_Invariants (Priv_T) then
+ Set_Has_Invariants (Full_T);
+ Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T));
+ end if;
- Insert_Range_Checks
- (R_Checks,
- Insert_Node,
- Def_Id,
- Sloc (Insert_Node),
- R,
- Do_Before => True);
- end if;
- end;
+ if Has_Inheritable_Invariants (Priv_T) then
+ Set_Has_Inheritable_Invariants (Full_T);
+ end if;
- -- Insertion before a declaration. If the declaration
- -- includes discriminants, the list of applicable checks
- -- is given by the caller.
+ -- Check hidden inheritance of class-wide type invariants
- elsif Nkind (Insert_Node) in N_Declaration then
- Def_Id := Defining_Identifier (Insert_Node);
+ if Ada_Version >= Ada_2012
+ and then not Has_Inheritable_Invariants (Full_T)
+ and then In_Private_Part (Current_Scope)
+ and then Has_Interfaces (Full_T)
+ then
+ declare
+ Ifaces : Elist_Id;
+ AI : Elmt_Id;
- if (Ekind (Def_Id) = E_Record_Type
- and then Depends_On_Discriminant (R))
- or else
- (Ekind (Def_Id) = E_Protected_Type
- and then Has_Discriminants (Def_Id))
- then
- Append_Range_Checks
- (R_Checks,
- Check_List, Def_Id, Sloc (Insert_Node), R);
+ begin
+ Collect_Interfaces (Full_T, Ifaces, Exclude_Parents => True);
- else
- Insert_Range_Checks
- (R_Checks,
- Insert_Node, Def_Id, Sloc (Insert_Node), R);
+ AI := First_Elmt (Ifaces);
+ while Present (AI) loop
+ if Has_Inheritable_Invariants (Node (AI)) then
+ Error_Msg_N
+ ("hidden inheritance of class-wide type invariants " &
+ "not allowed", N);
+ exit;
+ end if;
- end if;
+ Next_Elmt (AI);
+ end loop;
+ end;
+ end if;
- -- Insertion before a statement. Range appears in the
- -- context of a quantified expression. Insertion will
- -- take place when expression is expanded.
+ -- Propagate predicates to full type, and predicate function if already
+ -- defined. It is not clear that this can actually happen? the partial
+ -- view cannot be frozen yet, and the predicate function has not been
+ -- built. Still it is a cheap check and seems safer to make it.
- else
- null;
- end if;
- end if;
- end if;
+ if Has_Predicates (Priv_T) then
+ if Present (Predicate_Function (Priv_T)) then
+ Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
end if;
- -- Case of other than an explicit N_Range node
+ Set_Has_Predicates (Full_T);
+ end if;
+ end Process_Full_View;
- -- The forced evaluation removes side effects from expressions, which
- -- should occur also in GNATprove mode. Otherwise, we end up with
- -- unexpected insertions of actions at places where this is not
- -- supposed to occur, e.g. on default parameters of a call.
+ -----------------------------------
+ -- Process_Incomplete_Dependents --
+ -----------------------------------
- elsif Expander_Active or GNATprove_Mode then
- Get_Index_Bounds (R, Lo, Hi);
- Force_Evaluation (Lo);
- Force_Evaluation (Hi);
+ procedure Process_Incomplete_Dependents
+ (N : Node_Id;
+ Full_T : Entity_Id;
+ Inc_T : Entity_Id)
+ is
+ Inc_Elmt : Elmt_Id;
+ Priv_Dep : Entity_Id;
+ New_Subt : Entity_Id;
+
+ Disc_Constraint : Elist_Id;
+
+ begin
+ if No (Private_Dependents (Inc_T)) then
+ return;
end if;
- end Process_Range_Expr_In_Decl;
- --------------------------------------
- -- Process_Real_Range_Specification --
- --------------------------------------
+ -- Itypes that may be generated by the completion of an incomplete
+ -- subtype are not used by the back-end and not attached to the tree.
+ -- They are created only for constraint-checking purposes.
- procedure Process_Real_Range_Specification (Def : Node_Id) is
- Spec : constant Node_Id := Real_Range_Specification (Def);
- Lo : Node_Id;
- Hi : Node_Id;
- Err : Boolean := False;
+ Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
+ while Present (Inc_Elmt) loop
+ Priv_Dep := Node (Inc_Elmt);
- procedure Analyze_Bound (N : Node_Id);
- -- Analyze and check one bound
+ if Ekind (Priv_Dep) = E_Subprogram_Type then
- -------------------
- -- Analyze_Bound --
- -------------------
+ -- An Access_To_Subprogram type may have a return type or a
+ -- parameter type that is incomplete. Replace with the full view.
- procedure Analyze_Bound (N : Node_Id) is
- begin
- Analyze_And_Resolve (N, Any_Real);
+ if Etype (Priv_Dep) = Inc_T then
+ Set_Etype (Priv_Dep, Full_T);
+ end if;
- if not Is_OK_Static_Expression (N) then
- Flag_Non_Static_Expr
- ("bound in real type definition is not static!", N);
- Err := True;
- end if;
- end Analyze_Bound;
+ declare
+ Formal : Entity_Id;
- -- Start of processing for Process_Real_Range_Specification
+ begin
+ Formal := First_Formal (Priv_Dep);
+ while Present (Formal) loop
+ if Etype (Formal) = Inc_T then
+ Set_Etype (Formal, Full_T);
+ end if;
- begin
- if Present (Spec) then
- Lo := Low_Bound (Spec);
- Hi := High_Bound (Spec);
- Analyze_Bound (Lo);
- Analyze_Bound (Hi);
+ Next_Formal (Formal);
+ end loop;
+ end;
- -- If error, clear away junk range specification
+ elsif Is_Overloadable (Priv_Dep) then
- if Err then
- Set_Real_Range_Specification (Def, Empty);
- end if;
- end if;
- end Process_Real_Range_Specification;
+ -- If a subprogram in the incomplete dependents list is primitive
+ -- for a tagged full type then mark it as a dispatching operation,
+ -- check whether it overrides an inherited subprogram, and check
+ -- restrictions on its controlling formals. Note that a protected
+ -- operation is never dispatching: only its wrapper operation
+ -- (which has convention Ada) is.
- ---------------------
- -- Process_Subtype --
- ---------------------
+ if Is_Tagged_Type (Full_T)
+ and then Is_Primitive (Priv_Dep)
+ and then Convention (Priv_Dep) /= Convention_Protected
+ then
+ Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T);
+ Set_Is_Dispatching_Operation (Priv_Dep);
+ Check_Controlling_Formals (Full_T, Priv_Dep);
+ end if;
- function Process_Subtype
- (S : Node_Id;
- Related_Nod : Node_Id;
- Related_Id : Entity_Id := Empty;
- Suffix : Character := ' ') return Entity_Id
- is
- P : Node_Id;
- Def_Id : Entity_Id;
- Error_Node : Node_Id;
- Full_View_Id : Entity_Id;
- Subtype_Mark_Id : Entity_Id;
+ elsif Ekind (Priv_Dep) = E_Subprogram_Body then
- May_Have_Null_Exclusion : Boolean;
+ -- Can happen during processing of a body before the completion
+ -- of a TA type. Ignore, because spec is also on dependent list.
- procedure Check_Incomplete (T : Entity_Id);
- -- Called to verify that an incomplete type is not used prematurely
+ return;
- ----------------------
- -- Check_Incomplete --
- ----------------------
+ -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a
+ -- corresponding subtype of the full view.
- procedure Check_Incomplete (T : Entity_Id) is
- begin
- -- Ada 2005 (AI-412): Incomplete subtypes are legal
+ elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then
+ Set_Subtype_Indication
+ (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep)));
+ Set_Etype (Priv_Dep, Full_T);
+ Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
+ Set_Analyzed (Parent (Priv_Dep), False);
- if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
- and then
- not (Ada_Version >= Ada_2005
- and then
- (Nkind (Parent (T)) = N_Subtype_Declaration
- or else
- (Nkind (Parent (T)) = N_Subtype_Indication
- and then Nkind (Parent (Parent (T))) =
- N_Subtype_Declaration)))
- then
- Error_Msg_N ("invalid use of type before its full declaration", T);
- end if;
- end Check_Incomplete;
+ -- Reanalyze the declaration, suppressing the call to
+ -- Enter_Name to avoid duplicate names.
- -- Start of processing for Process_Subtype
+ Analyze_Subtype_Declaration
+ (N => Parent (Priv_Dep),
+ Skip => True);
- begin
- -- Case of no constraints present
+ -- Dependent is a subtype
- if Nkind (S) /= N_Subtype_Indication then
- Find_Type (S);
- Check_Incomplete (S);
- P := Parent (S);
+ else
+ -- We build a new subtype indication using the full view of the
+ -- incomplete parent. The discriminant constraints have been
+ -- elaborated already at the point of the subtype declaration.
- -- Ada 2005 (AI-231): Static check
+ New_Subt := Create_Itype (E_Void, N);
- if Ada_Version >= Ada_2005
- and then Present (P)
- and then Null_Exclusion_Present (P)
- and then Nkind (P) /= N_Access_To_Object_Definition
- and then not Is_Access_Type (Entity (S))
- then
- Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
+ if Has_Discriminants (Full_T) then
+ Disc_Constraint := Discriminant_Constraint (Priv_Dep);
+ else
+ Disc_Constraint := No_Elist;
+ end if;
+
+ Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N);
+ Set_Full_View (Priv_Dep, New_Subt);
end if;
- -- The following is ugly, can't we have a range or even a flag???
+ Next_Elmt (Inc_Elmt);
+ end loop;
+ end Process_Incomplete_Dependents;
- May_Have_Null_Exclusion :=
- Nkind_In (P, N_Access_Definition,
- N_Access_Function_Definition,
- N_Access_Procedure_Definition,
- N_Access_To_Object_Definition,
- N_Allocator,
- N_Component_Definition)
- or else
- Nkind_In (P, N_Derived_Type_Definition,
- N_Discriminant_Specification,
- N_Formal_Object_Declaration,
- N_Object_Declaration,
- N_Object_Renaming_Declaration,
- N_Parameter_Specification,
- N_Subtype_Declaration);
+ --------------------------------
+ -- Process_Range_Expr_In_Decl --
+ --------------------------------
- -- Create an Itype that is a duplicate of Entity (S) but with the
- -- null-exclusion attribute.
+ procedure Process_Range_Expr_In_Decl
+ (R : Node_Id;
+ T : Entity_Id;
+ Subtyp : Entity_Id := Empty;
+ Check_List : List_Id := Empty_List;
+ R_Check_Off : Boolean := False;
+ In_Iter_Schm : Boolean := False)
+ is
+ Lo, Hi : Node_Id;
+ R_Checks : Check_Result;
+ Insert_Node : Node_Id;
+ Def_Id : Entity_Id;
- if May_Have_Null_Exclusion
- and then Is_Access_Type (Entity (S))
- and then Null_Exclusion_Present (P)
+ begin
+ Analyze_And_Resolve (R, Base_Type (T));
- -- No need to check the case of an access to object definition.
- -- It is correct to define double not-null pointers.
+ if Nkind (R) = N_Range then
- -- Example:
- -- type Not_Null_Int_Ptr is not null access Integer;
- -- type Acc is not null access Not_Null_Int_Ptr;
+ -- In SPARK, all ranges should be static, with the exception of the
+ -- discrete type definition of a loop parameter specification.
- and then Nkind (P) /= N_Access_To_Object_Definition
+ if not In_Iter_Schm
+ and then not Is_OK_Static_Range (R)
then
- if Can_Never_Be_Null (Entity (S)) then
- case Nkind (Related_Nod) is
- when N_Full_Type_Declaration =>
- if Nkind (Type_Definition (Related_Nod))
- in N_Array_Type_Definition
- then
- Error_Node :=
- Subtype_Indication
- (Component_Definition
- (Type_Definition (Related_Nod)));
- else
- Error_Node :=
- Subtype_Indication (Type_Definition (Related_Nod));
- end if;
-
- when N_Subtype_Declaration =>
- Error_Node := Subtype_Indication (Related_Nod);
+ Check_SPARK_05_Restriction ("range should be static", R);
+ end if;
- when N_Object_Declaration =>
- Error_Node := Object_Definition (Related_Nod);
+ Lo := Low_Bound (R);
+ Hi := High_Bound (R);
- when N_Component_Declaration =>
- Error_Node :=
- Subtype_Indication (Component_Definition (Related_Nod));
+ -- Validity checks on the range of a quantified expression are
+ -- delayed until the construct is transformed into a loop.
- when N_Allocator =>
- Error_Node := Expression (Related_Nod);
+ if Nkind (Parent (R)) = N_Loop_Parameter_Specification
+ and then Nkind (Parent (Parent (R))) = N_Quantified_Expression
+ then
+ null;
- when others =>
- pragma Assert (False);
- Error_Node := Related_Nod;
- end case;
+ -- We need to ensure validity of the bounds here, because if we
+ -- go ahead and do the expansion, then the expanded code will get
+ -- analyzed with range checks suppressed and we miss the check.
- Error_Msg_NE
- ("`NOT NULL` not allowed (& already excludes null)",
- Error_Node,
- Entity (S));
- end if;
+ -- WARNING: The capture of the range bounds with xxx_FIRST/_LAST and
+ -- the temporaries generated by routine Remove_Side_Effects by means
+ -- of validity checks must use the same names. When a range appears
+ -- in the parent of a generic, the range is processed with checks
+ -- disabled as part of the generic context and with checks enabled
+ -- for code generation purposes. This leads to link issues as the
+ -- generic contains references to xxx_FIRST/_LAST, but the inlined
+ -- template sees the temporaries generated by Remove_Side_Effects.
- Set_Etype (S,
- Create_Null_Excluding_Itype
- (T => Entity (S),
- Related_Nod => P));
- Set_Entity (S, Etype (S));
+ else
+ Validity_Check_Range (R, Subtyp);
end if;
- return Entity (S);
+ -- If there were errors in the declaration, try and patch up some
+ -- common mistakes in the bounds. The cases handled are literals
+ -- which are Integer where the expected type is Real and vice versa.
+ -- These corrections allow the compilation process to proceed further
+ -- along since some basic assumptions of the format of the bounds
+ -- are guaranteed.
- -- Case of constraint present, so that we have an N_Subtype_Indication
- -- node (this node is created only if constraints are present).
+ 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))));
- else
- Find_Type (Subtype_Mark (S));
+ elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then
+ Rewrite (Hi,
+ Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi))));
- 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));
+ 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;
- P := Parent (S);
- Subtype_Mark_Id := Entity (Subtype_Mark (S));
+ -- If the bounds of the range have been mistakenly given as string
+ -- literals (perhaps in place of character literals), then an error
+ -- has already been reported, but we rewrite the string literal as a
+ -- bound of the range's type to avoid blowups in later processing
+ -- that looks at static values.
- -- Explicit subtype declaration case
+ if Nkind (Lo) = N_String_Literal then
+ Rewrite (Lo,
+ Make_Attribute_Reference (Sloc (Lo),
+ Prefix => New_Occurrence_Of (T, Sloc (Lo)),
+ Attribute_Name => Name_First));
+ Analyze_And_Resolve (Lo);
+ end if;
- if Nkind (P) = N_Subtype_Declaration then
- Def_Id := Defining_Identifier (P);
+ if Nkind (Hi) = N_String_Literal then
+ Rewrite (Hi,
+ Make_Attribute_Reference (Sloc (Hi),
+ Prefix => New_Occurrence_Of (T, Sloc (Hi)),
+ Attribute_Name => Name_First));
+ Analyze_And_Resolve (Hi);
+ end if;
- -- Explicit derived type definition case
+ -- If bounds aren't scalar at this point then exit, avoiding
+ -- problems with further processing of the range in this procedure.
- elsif Nkind (P) = N_Derived_Type_Definition then
- Def_Id := Defining_Identifier (Parent (P));
+ if not Is_Scalar_Type (Etype (Lo)) then
+ return;
+ end if;
- -- Implicit case, the Def_Id must be created as an implicit type.
- -- The one exception arises in the case of concurrent types, array
- -- and access types, where other subsidiary implicit types may be
- -- created and must appear before the main implicit type. In these
- -- cases we leave Def_Id set to Empty as a signal that Create_Itype
- -- has not yet been called to create Def_Id.
+ -- Resolve (actually Sem_Eval) has checked that the bounds are in
+ -- then range of the base type. Here we check whether the bounds
+ -- are in the range of the subtype itself. Note that if the bounds
+ -- represent the null range the Constraint_Error exception should
+ -- not be raised.
- 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;
+ -- ??? The following code should be cleaned up as follows
- -- For the other cases, we create a new unattached Itype,
- -- and set the indication to ensure it gets attached later.
+ -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
+ -- is done in the call to Range_Check (R, T); below
- else
- Def_Id :=
- Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
- end if;
- end if;
+ -- 2. The use of R_Check_Off should be investigated and possibly
+ -- removed, this would clean up things a bit.
- -- If the kind of constraint is invalid for this kind of type,
- -- then give an error, and then pretend no constraint was given.
+ if Is_Null_Range (Lo, Hi) then
+ null;
- 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));
+ else
+ -- Capture values of bounds and generate temporaries for them
+ -- if needed, before applying checks, since checks may cause
+ -- duplication of the expression without forcing evaluation.
- Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
+ -- The forced evaluation removes side effects from expressions,
+ -- which should occur also in GNATprove mode. Otherwise, we end up
+ -- with unexpected insertions of actions at places where this is
+ -- not supposed to occur, e.g. on default parameters of a call.
- -- Set Ekind of orphan itype, to prevent cascaded errors
+ if Expander_Active or GNATprove_Mode then
- if Present (Def_Id) then
- Set_Ekind (Def_Id, Ekind (Any_Type));
- end if;
+ -- Call Force_Evaluation to create declarations as needed to
+ -- deal with side effects, and also create typ_FIRST/LAST
+ -- entities for bounds if we have a subtype name.
- -- Make recursive call, having got rid of the bogus constraint
+ -- Note: we do this transformation even if expansion is not
+ -- active if we are in GNATprove_Mode since the transformation
+ -- is in general required to ensure that the resulting tree has
+ -- proper Ada semantics.
+
+ Force_Evaluation
+ (Lo, Related_Id => Subtyp, Is_Low_Bound => True);
+ Force_Evaluation
+ (Hi, Related_Id => Subtyp, Is_High_Bound => True);
+ end if;
- return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
- end if;
+ -- We use a flag here instead of suppressing checks on the type
+ -- because the type we check against isn't necessarily the place
+ -- where we put the check.
- -- Remaining processing depends on type. Select on Base_Type kind to
- -- ensure getting to the concrete type kind in the case of a private
- -- subtype (needed when only doing semantic analysis).
+ if not R_Check_Off then
+ R_Checks := Get_Range_Checks (R, T);
- case Ekind (Base_Type (Subtype_Mark_Id)) is
- when Access_Kind =>
+ -- Look up tree to find an appropriate insertion point. We
+ -- can't just use insert_actions because later processing
+ -- depends on the insertion node. Prior to Ada 2012 the
+ -- insertion point could only be a declaration or a loop, but
+ -- quantified expressions can appear within any context in an
+ -- expression, and the insertion point can be any statement,
+ -- pragma, or declaration.
- -- If this is a constraint on a class-wide type, discard it.
- -- There is currently no way to express a partial discriminant
- -- constraint on a type with unknown discriminants. This is
- -- a pathology that the ACATS wisely decides not to test.
+ Insert_Node := Parent (R);
+ while Present (Insert_Node) loop
+ exit when
+ Nkind (Insert_Node) in N_Declaration
+ and then
+ not Nkind_In
+ (Insert_Node, N_Component_Declaration,
+ N_Loop_Parameter_Specification,
+ N_Function_Specification,
+ N_Procedure_Specification);
- if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then
- if Comes_From_Source (S) then
- Error_Msg_N
- ("constraint on class-wide type ignored??",
- Constraint (S));
- end if;
+ exit when Nkind (Insert_Node) in N_Later_Decl_Item
+ or else Nkind (Insert_Node) in
+ N_Statement_Other_Than_Procedure_Call
+ or else Nkind_In (Insert_Node, N_Procedure_Call_Statement,
+ N_Pragma);
- if Nkind (P) = N_Subtype_Declaration then
- Set_Subtype_Indication (P,
- New_Occurrence_Of (Subtype_Mark_Id, Sloc (S)));
- end if;
+ Insert_Node := Parent (Insert_Node);
+ end loop;
- return Subtype_Mark_Id;
- end if;
+ -- Why would Type_Decl not be present??? Without this test,
+ -- short regression tests fail.
- Constrain_Access (Def_Id, S, Related_Nod);
+ if Present (Insert_Node) then
- if Expander_Active
- and then Is_Itype (Designated_Type (Def_Id))
- and then Nkind (Related_Nod) = N_Subtype_Declaration
- and then not Is_Incomplete_Type (Designated_Type (Def_Id))
- then
- Build_Itype_Reference
- (Designated_Type (Def_Id), Related_Nod);
- end if;
+ -- Case of loop statement. Verify that the range is part
+ -- of the subtype indication of the iteration scheme.
- when Array_Kind =>
- Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
+ if Nkind (Insert_Node) = N_Loop_Statement then
+ declare
+ Indic : Node_Id;
- when Decimal_Fixed_Point_Kind =>
- Constrain_Decimal (Def_Id, S);
+ begin
+ Indic := Parent (R);
+ while Present (Indic)
+ and then Nkind (Indic) /= N_Subtype_Indication
+ loop
+ Indic := Parent (Indic);
+ end loop;
- when Enumeration_Kind =>
- Constrain_Enumeration (Def_Id, S);
- Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
+ if Present (Indic) then
+ Def_Id := Etype (Subtype_Mark (Indic));
- when Ordinary_Fixed_Point_Kind =>
- Constrain_Ordinary_Fixed (Def_Id, S);
+ Insert_Range_Checks
+ (R_Checks,
+ Insert_Node,
+ Def_Id,
+ Sloc (Insert_Node),
+ R,
+ Do_Before => True);
+ end if;
+ end;
- when Float_Kind =>
- Constrain_Float (Def_Id, S);
+ -- Insertion before a declaration. If the declaration
+ -- includes discriminants, the list of applicable checks
+ -- is given by the caller.
- when Integer_Kind =>
- Constrain_Integer (Def_Id, S);
- Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
+ elsif Nkind (Insert_Node) in N_Declaration then
+ Def_Id := Defining_Identifier (Insert_Node);
- when E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- E_Incomplete_Type =>
- Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+ if (Ekind (Def_Id) = E_Record_Type
+ and then Depends_On_Discriminant (R))
+ or else
+ (Ekind (Def_Id) = E_Protected_Type
+ and then Has_Discriminants (Def_Id))
+ then
+ Append_Range_Checks
+ (R_Checks,
+ Check_List, Def_Id, Sloc (Insert_Node), R);
- if Ekind (Def_Id) = E_Incomplete_Type then
- Set_Private_Dependents (Def_Id, New_Elmt_List);
- end if;
+ else
+ Insert_Range_Checks
+ (R_Checks,
+ Insert_Node, Def_Id, Sloc (Insert_Node), R);
- when Private_Kind =>
- Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
- Set_Private_Dependents (Def_Id, New_Elmt_List);
+ end if;
- -- In case of an invalid constraint prevent further processing
- -- since the type constructed is missing expected fields.
+ -- Insertion before a statement. Range appears in the
+ -- context of a quantified expression. Insertion will
+ -- take place when expression is expanded.
- if Etype (Def_Id) = Any_Type then
- return Def_Id;
+ else
+ null;
+ end if;
end if;
+ end if;
+ end if;
- -- If the full view is that of a task with discriminants,
- -- we must constrain both the concurrent type and its
- -- corresponding record type. Otherwise we will just propagate
- -- the constraint to the full view, if available.
+ -- Case of other than an explicit N_Range node
- 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);
+ -- The forced evaluation removes side effects from expressions, which
+ -- should occur also in GNATprove mode. Otherwise, we end up with
+ -- unexpected insertions of actions at places where this is not
+ -- supposed to occur, e.g. on default parameters of a call.
- 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);
+ elsif Expander_Active or GNATprove_Mode then
+ Get_Index_Bounds (R, Lo, Hi);
+ Force_Evaluation (Lo);
+ Force_Evaluation (Hi);
+ end if;
+ end Process_Range_Expr_In_Decl;
- -- Introduce an explicit reference to the private subtype,
- -- to prevent scope anomalies in gigi if first use appears
- -- in a nested context, e.g. a later function body.
- -- Should this be generated in other contexts than a full
- -- type declaration?
+ --------------------------------------
+ -- Process_Real_Range_Specification --
+ --------------------------------------
- if Is_Itype (Def_Id)
- and then
- Nkind (Parent (P)) = N_Full_Type_Declaration
- then
- Build_Itype_Reference (Def_Id, Parent (P));
- end if;
+ 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;
- else
- Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
- end if;
+ procedure Analyze_Bound (N : Node_Id);
+ -- Analyze and check one bound
- when Concurrent_Kind =>
- Constrain_Concurrent (Def_Id, S,
- Related_Nod, Related_Id, Suffix);
+ -------------------
+ -- Analyze_Bound --
+ -------------------
- when others =>
- Error_Msg_N ("invalid subtype mark in subtype indication", S);
- end case;
+ procedure Analyze_Bound (N : Node_Id) is
+ begin
+ Analyze_And_Resolve (N, Any_Real);
- -- Size and Convention are always inherited from the base type
+ if not Is_OK_Static_Expression (N) then
+ Flag_Non_Static_Expr
+ ("bound in real type definition is not static!", N);
+ Err := True;
+ end if;
+ end Analyze_Bound;
- Set_Size_Info (Def_Id, (Subtype_Mark_Id));
- Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
+ -- Start of processing for Process_Real_Range_Specification
- return Def_Id;
+ begin
+ if Present (Spec) then
+ Lo := Low_Bound (Spec);
+ Hi := High_Bound (Spec);
+ Analyze_Bound (Lo);
+ Analyze_Bound (Hi);
+
+ -- If error, clear away junk range specification
+
+ if Err then
+ Set_Real_Range_Specification (Def, Empty);
+ end if;
end if;
- end Process_Subtype;
+ end Process_Real_Range_Specification;
- ---------------------------------------
- -- Check_Anonymous_Access_Components --
- ---------------------------------------
+ ---------------------
+ -- Process_Subtype --
+ ---------------------
- procedure Check_Anonymous_Access_Components
- (Typ_Decl : Node_Id;
- Typ : Entity_Id;
- Prev : Entity_Id;
- Comp_List : Node_Id)
+ function Process_Subtype
+ (S : Node_Id;
+ Related_Nod : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Suffix : Character := ' ') return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (Typ_Decl);
- Anon_Access : Entity_Id;
- Acc_Def : Node_Id;
- Comp : Node_Id;
- Comp_Def : Node_Id;
- Decl : Node_Id;
- Type_Def : Node_Id;
+ P : Node_Id;
+ Def_Id : Entity_Id;
+ Error_Node : Node_Id;
+ Full_View_Id : Entity_Id;
+ Subtype_Mark_Id : Entity_Id;
- procedure Build_Incomplete_Type_Declaration;
- -- If the record type contains components that include an access to the
- -- current record, then create an incomplete type declaration for the
- -- record, to be used as the designated type of the anonymous access.
- -- This is done only once, and only if there is no previous partial
- -- view of the type.
+ May_Have_Null_Exclusion : Boolean;
- function Designates_T (Subt : Node_Id) return Boolean;
- -- Check whether a node designates the enclosing record type, or 'Class
- -- of that type
+ procedure Check_Incomplete (T : Entity_Id);
+ -- Called to verify that an incomplete type is not used prematurely
- function Mentions_T (Acc_Def : Node_Id) return Boolean;
- -- Check whether an access definition includes a reference to
- -- the enclosing record type. The reference can be a subtype mark
- -- in the access definition itself, a 'Class attribute reference, or
- -- recursively a reference appearing in a parameter specification
- -- or result definition of an access_to_subprogram definition.
+ ----------------------
+ -- Check_Incomplete --
+ ----------------------
- --------------------------------------
- -- Build_Incomplete_Type_Declaration --
- --------------------------------------
+ procedure Check_Incomplete (T : Entity_Id) is
+ begin
+ -- Ada 2005 (AI-412): Incomplete subtypes are legal
- procedure Build_Incomplete_Type_Declaration is
- Decl : Node_Id;
- Inc_T : Entity_Id;
- H : Entity_Id;
+ if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
+ and then
+ not (Ada_Version >= Ada_2005
+ and then
+ (Nkind (Parent (T)) = N_Subtype_Declaration
+ or else (Nkind (Parent (T)) = N_Subtype_Indication
+ and then Nkind (Parent (Parent (T))) =
+ N_Subtype_Declaration)))
+ then
+ Error_Msg_N ("invalid use of type before its full declaration", T);
+ end if;
+ end Check_Incomplete;
- -- Is_Tagged indicates whether the type is tagged. It is tagged if
- -- it's "is new ... with record" or else "is tagged record ...".
+ -- Start of processing for Process_Subtype
- Is_Tagged : constant Boolean :=
- (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
- and then
- Present
- (Record_Extension_Part (Type_Definition (Typ_Decl))))
- or else
- (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition
- and then Tagged_Present (Type_Definition (Typ_Decl)));
+ begin
+ -- Case of no constraints present
- begin
- -- If there is a previous partial view, no need to create a new one
- -- If the partial view, given by Prev, is incomplete, If Prev is
- -- a private declaration, full declaration is flagged accordingly.
+ if Nkind (S) /= N_Subtype_Indication then
+ Find_Type (S);
+ Check_Incomplete (S);
+ P := Parent (S);
- if Prev /= Typ then
- if Is_Tagged then
- Make_Class_Wide_Type (Prev);
- Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev));
- Set_Etype (Class_Wide_Type (Typ), Typ);
- end if;
+ -- Ada 2005 (AI-231): Static check
+
+ if Ada_Version >= Ada_2005
+ and then Present (P)
+ and then Null_Exclusion_Present (P)
+ and then Nkind (P) /= N_Access_To_Object_Definition
+ and then not Is_Access_Type (Entity (S))
+ then
+ Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
+ end if;
- return;
+ -- The following is ugly, can't we have a range or even a flag???
- elsif Has_Private_Declaration (Typ) then
+ May_Have_Null_Exclusion :=
+ Nkind_In (P, N_Access_Definition,
+ N_Access_Function_Definition,
+ N_Access_Procedure_Definition,
+ N_Access_To_Object_Definition,
+ N_Allocator,
+ N_Component_Definition)
+ or else
+ Nkind_In (P, N_Derived_Type_Definition,
+ N_Discriminant_Specification,
+ N_Formal_Object_Declaration,
+ N_Object_Declaration,
+ N_Object_Renaming_Declaration,
+ N_Parameter_Specification,
+ N_Subtype_Declaration);
- -- If we refer to T'Class inside T, and T is the completion of a
- -- private type, then we need to make sure the class-wide type
- -- exists.
+ -- Create an Itype that is a duplicate of Entity (S) but with the
+ -- null-exclusion attribute.
- if Is_Tagged then
- Make_Class_Wide_Type (Typ);
- end if;
+ if May_Have_Null_Exclusion
+ and then Is_Access_Type (Entity (S))
+ and then Null_Exclusion_Present (P)
- return;
+ -- No need to check the case of an access to object definition.
+ -- It is correct to define double not-null pointers.
- -- If there was a previous anonymous access type, the incomplete
- -- type declaration will have been created already.
+ -- Example:
+ -- type Not_Null_Int_Ptr is not null access Integer;
+ -- type Acc is not null access Not_Null_Int_Ptr;
- elsif Present (Current_Entity (Typ))
- and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
- and then Full_View (Current_Entity (Typ)) = Typ
+ and then Nkind (P) /= N_Access_To_Object_Definition
then
- if Is_Tagged
- and then Comes_From_Source (Current_Entity (Typ))
- and then not Is_Tagged_Type (Current_Entity (Typ))
- then
- Make_Class_Wide_Type (Typ);
- Error_Msg_N
- ("incomplete view of tagged type should be declared tagged??",
- Parent (Current_Entity (Typ)));
- end if;
- return;
+ if Can_Never_Be_Null (Entity (S)) then
+ case Nkind (Related_Nod) is
+ when N_Full_Type_Declaration =>
+ if Nkind (Type_Definition (Related_Nod))
+ in N_Array_Type_Definition
+ then
+ Error_Node :=
+ Subtype_Indication
+ (Component_Definition
+ (Type_Definition (Related_Nod)));
+ else
+ Error_Node :=
+ Subtype_Indication (Type_Definition (Related_Nod));
+ end if;
- else
- Inc_T := Make_Defining_Identifier (Loc, Chars (Typ));
- Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T);
+ when N_Subtype_Declaration =>
+ Error_Node := Subtype_Indication (Related_Nod);
- -- Type has already been inserted into the current scope. Remove
- -- it, and add incomplete declaration for type, so that subsequent
- -- anonymous access types can use it. The entity is unchained from
- -- the homonym list and from immediate visibility. After analysis,
- -- the entity in the incomplete declaration becomes immediately
- -- visible in the record declaration that follows.
+ when N_Object_Declaration =>
+ Error_Node := Object_Definition (Related_Nod);
- H := Current_Entity (Typ);
+ when N_Component_Declaration =>
+ Error_Node :=
+ Subtype_Indication (Component_Definition (Related_Nod));
- if H = Typ then
- Set_Name_Entity_Id (Chars (Typ), Homonym (Typ));
- else
- while Present (H)
- and then Homonym (H) /= Typ
- loop
- H := Homonym (Typ);
- end loop;
+ when N_Allocator =>
+ Error_Node := Expression (Related_Nod);
- Set_Homonym (H, Homonym (Typ));
+ when others =>
+ pragma Assert (False);
+ Error_Node := Related_Nod;
+ end case;
+
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ Error_Node,
+ Entity (S));
end if;
- Insert_Before (Typ_Decl, Decl);
- Analyze (Decl);
- Set_Full_View (Inc_T, Typ);
+ Set_Etype (S,
+ Create_Null_Excluding_Itype
+ (T => Entity (S),
+ Related_Nod => P));
+ Set_Entity (S, Etype (S));
+ end if;
- if Is_Tagged then
+ return Entity (S);
- -- Create a common class-wide type for both views, and set the
- -- Etype of the class-wide type to the full view.
+ -- Case of constraint present, so that we have an N_Subtype_Indication
+ -- node (this node is created only if constraints are present).
- Make_Class_Wide_Type (Inc_T);
- Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T));
- Set_Etype (Class_Wide_Type (Typ), Typ);
- end if;
+ else
+ Find_Type (Subtype_Mark (S));
+
+ if Nkind (Parent (S)) /= N_Access_To_Object_Definition
+ and then not
+ (Nkind (Parent (S)) = N_Subtype_Declaration
+ and then Is_Itype (Defining_Identifier (Parent (S))))
+ then
+ Check_Incomplete (Subtype_Mark (S));
end if;
- end Build_Incomplete_Type_Declaration;
- ------------------
- -- Designates_T --
- ------------------
+ P := Parent (S);
+ Subtype_Mark_Id := Entity (Subtype_Mark (S));
- function Designates_T (Subt : Node_Id) return Boolean is
- Type_Id : constant Name_Id := Chars (Typ);
+ -- Explicit subtype declaration case
- function Names_T (Nam : Node_Id) return Boolean;
- -- The record type has not been introduced in the current scope
- -- yet, so we must examine the name of the type itself, either
- -- an identifier T, or an expanded name of the form P.T, where
- -- P denotes the current scope.
+ if Nkind (P) = N_Subtype_Declaration then
+ Def_Id := Defining_Identifier (P);
- -------------
- -- Names_T --
- -------------
+ -- Explicit derived type definition case
- function Names_T (Nam : Node_Id) return Boolean is
- begin
- if Nkind (Nam) = N_Identifier then
- return Chars (Nam) = Type_Id;
+ elsif Nkind (P) = N_Derived_Type_Definition then
+ Def_Id := Defining_Identifier (Parent (P));
- elsif Nkind (Nam) = N_Selected_Component then
- if Chars (Selector_Name (Nam)) = Type_Id then
- if Nkind (Prefix (Nam)) = N_Identifier then
- return Chars (Prefix (Nam)) = Chars (Current_Scope);
+ -- Implicit case, the Def_Id must be created as an implicit type.
+ -- The one exception arises in the case of concurrent types, array
+ -- and access types, where other subsidiary implicit types may be
+ -- created and must appear before the main implicit type. In these
+ -- cases we leave Def_Id set to Empty as a signal that Create_Itype
+ -- has not yet been called to create Def_Id.
- elsif Nkind (Prefix (Nam)) = N_Selected_Component then
- return Chars (Selector_Name (Prefix (Nam))) =
- Chars (Current_Scope);
- else
- return False;
- end if;
+ else
+ if Is_Array_Type (Subtype_Mark_Id)
+ or else Is_Concurrent_Type (Subtype_Mark_Id)
+ or else Is_Access_Type (Subtype_Mark_Id)
+ then
+ Def_Id := Empty;
- else
- return False;
- end if;
+ -- For the other cases, we create a new unattached Itype,
+ -- and set the indication to ensure it gets attached later.
else
- return False;
+ Def_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
end if;
- end Names_T;
-
- -- Start of processing for Designates_T
+ end if;
- begin
- if Nkind (Subt) = N_Identifier then
- return Chars (Subt) = Type_Id;
+ -- If the kind of constraint is invalid for this kind of type,
+ -- then give an error, and then pretend no constraint was given.
- -- Reference can be through an expanded name which has not been
- -- analyzed yet, and which designates enclosing scopes.
+ if not Is_Valid_Constraint_Kind
+ (Ekind (Subtype_Mark_Id), Nkind (Constraint (S)))
+ then
+ Error_Msg_N
+ ("incorrect constraint for this kind of type", Constraint (S));
- elsif Nkind (Subt) = N_Selected_Component then
- if Names_T (Subt) then
- return True;
+ Rewrite (S, New_Copy_Tree (Subtype_Mark (S)));
- -- Otherwise it must denote an entity that is already visible.
- -- The access definition may name a subtype of the enclosing
- -- type, if there is a previous incomplete declaration for it.
+ -- Set Ekind of orphan itype, to prevent cascaded errors
- else
- Find_Selected_Component (Subt);
- return
- Is_Entity_Name (Subt)
- and then Scope (Entity (Subt)) = Current_Scope
- and then
- (Chars (Base_Type (Entity (Subt))) = Type_Id
- or else
- (Is_Class_Wide_Type (Entity (Subt))
- and then
- Chars (Etype (Base_Type (Entity (Subt)))) =
- Type_Id));
+ if Present (Def_Id) then
+ Set_Ekind (Def_Id, Ekind (Any_Type));
end if;
- -- A reference to the current type may appear as the prefix of
- -- a 'Class attribute.
-
- elsif Nkind (Subt) = N_Attribute_Reference
- and then Attribute_Name (Subt) = Name_Class
- then
- return Names_T (Prefix (Subt));
+ -- Make recursive call, having got rid of the bogus constraint
- else
- return False;
+ return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
end if;
- end Designates_T;
- ----------------
- -- Mentions_T --
- ----------------
+ -- Remaining processing depends on type. Select on Base_Type kind to
+ -- ensure getting to the concrete type kind in the case of a private
+ -- subtype (needed when only doing semantic analysis).
+
+ case Ekind (Base_Type (Subtype_Mark_Id)) is
+ when Access_Kind =>
+
+ -- If this is a constraint on a class-wide type, discard it.
+ -- There is currently no way to express a partial discriminant
+ -- constraint on a type with unknown discriminants. This is
+ -- a pathology that the ACATS wisely decides not to test.
+
+ if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then
+ if Comes_From_Source (S) then
+ Error_Msg_N
+ ("constraint on class-wide type ignored??",
+ Constraint (S));
+ end if;
- function Mentions_T (Acc_Def : Node_Id) return Boolean is
- Param_Spec : Node_Id;
+ if Nkind (P) = N_Subtype_Declaration then
+ Set_Subtype_Indication (P,
+ New_Occurrence_Of (Subtype_Mark_Id, Sloc (S)));
+ end if;
- Acc_Subprg : constant Node_Id :=
- Access_To_Subprogram_Definition (Acc_Def);
+ return Subtype_Mark_Id;
+ end if;
- begin
- if No (Acc_Subprg) then
- return Designates_T (Subtype_Mark (Acc_Def));
- end if;
+ Constrain_Access (Def_Id, S, Related_Nod);
- -- Component is an access_to_subprogram: examine its formals,
- -- and result definition in the case of an access_to_function.
+ if Expander_Active
+ and then Is_Itype (Designated_Type (Def_Id))
+ and then Nkind (Related_Nod) = N_Subtype_Declaration
+ and then not Is_Incomplete_Type (Designated_Type (Def_Id))
+ then
+ Build_Itype_Reference
+ (Designated_Type (Def_Id), Related_Nod);
+ end if;
- Param_Spec := First (Parameter_Specifications (Acc_Subprg));
- while Present (Param_Spec) loop
- if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition
- and then Mentions_T (Parameter_Type (Param_Spec))
- then
- return True;
+ when Array_Kind =>
+ Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
- elsif Designates_T (Parameter_Type (Param_Spec)) then
- return True;
- end if;
+ when Decimal_Fixed_Point_Kind =>
+ Constrain_Decimal (Def_Id, S);
- Next (Param_Spec);
- end loop;
+ when Enumeration_Kind =>
+ Constrain_Enumeration (Def_Id, S);
+ Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
- if Nkind (Acc_Subprg) = N_Access_Function_Definition then
- if Nkind (Result_Definition (Acc_Subprg)) =
- N_Access_Definition
- then
- return Mentions_T (Result_Definition (Acc_Subprg));
- else
- return Designates_T (Result_Definition (Acc_Subprg));
- end if;
- end if;
+ when Ordinary_Fixed_Point_Kind =>
+ Constrain_Ordinary_Fixed (Def_Id, S);
- return False;
- end Mentions_T;
+ when Float_Kind =>
+ Constrain_Float (Def_Id, S);
- -- Start of processing for Check_Anonymous_Access_Components
+ when Integer_Kind =>
+ Constrain_Integer (Def_Id, S);
+ Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
- begin
- if No (Comp_List) then
- return;
- end if;
+ when E_Record_Type |
+ E_Record_Subtype |
+ Class_Wide_Kind |
+ E_Incomplete_Type =>
+ Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
- Comp := First (Component_Items (Comp_List));
- while Present (Comp) loop
- if Nkind (Comp) = N_Component_Declaration
- and then Present
- (Access_Definition (Component_Definition (Comp)))
- and then
- Mentions_T (Access_Definition (Component_Definition (Comp)))
- then
- Comp_Def := Component_Definition (Comp);
- Acc_Def :=
- Access_To_Subprogram_Definition
- (Access_Definition (Comp_Def));
+ if Ekind (Def_Id) = E_Incomplete_Type then
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
+ end if;
- Build_Incomplete_Type_Declaration;
- Anon_Access := Make_Temporary (Loc, 'S');
+ when Private_Kind =>
+ Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
- -- Create a declaration for the anonymous access type: either
- -- an access_to_object or an access_to_subprogram.
+ -- In case of an invalid constraint prevent further processing
+ -- since the type constructed is missing expected fields.
- if Present (Acc_Def) then
- if Nkind (Acc_Def) = N_Access_Function_Definition then
- Type_Def :=
- Make_Access_Function_Definition (Loc,
- Parameter_Specifications =>
- Parameter_Specifications (Acc_Def),
- Result_Definition => Result_Definition (Acc_Def));
- else
- Type_Def :=
- Make_Access_Procedure_Definition (Loc,
- Parameter_Specifications =>
- Parameter_Specifications (Acc_Def));
+ if Etype (Def_Id) = Any_Type then
+ return Def_Id;
end if;
- else
- Type_Def :=
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- Relocate_Node
- (Subtype_Mark
- (Access_Definition (Comp_Def))));
+ -- If the full view is that of a task with discriminants,
+ -- we must constrain both the concurrent type and its
+ -- corresponding record type. Otherwise we will just propagate
+ -- the constraint to the full view, if available.
- Set_Constant_Present
- (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
- Set_All_Present
- (Type_Def, All_Present (Access_Definition (Comp_Def)));
- end if;
+ if Present (Full_View (Subtype_Mark_Id))
+ and then Has_Discriminants (Subtype_Mark_Id)
+ and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id))
+ then
+ Full_View_Id :=
+ Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
- Set_Null_Exclusion_Present
- (Type_Def,
- Null_Exclusion_Present (Access_Definition (Comp_Def)));
+ Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id));
+ Constrain_Concurrent (Full_View_Id, S,
+ Related_Nod, Related_Id, Suffix);
+ Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
+ Set_Full_View (Def_Id, Full_View_Id);
- Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Anon_Access,
- Type_Definition => Type_Def);
+ -- Introduce an explicit reference to the private subtype,
+ -- to prevent scope anomalies in gigi if first use appears
+ -- in a nested context, e.g. a later function body.
+ -- Should this be generated in other contexts than a full
+ -- type declaration?
- Insert_Before (Typ_Decl, Decl);
- Analyze (Decl);
+ if Is_Itype (Def_Id)
+ and then
+ Nkind (Parent (P)) = N_Full_Type_Declaration
+ then
+ Build_Itype_Reference (Def_Id, Parent (P));
+ end if;
- -- If an access to subprogram, create the extra formals
+ else
+ Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
+ end if;
- if Present (Acc_Def) then
- Create_Extra_Formals (Designated_Type (Anon_Access));
+ when Concurrent_Kind =>
+ Constrain_Concurrent (Def_Id, S,
+ Related_Nod, Related_Id, Suffix);
- -- If an access to object, preserve entity of designated type,
- -- for ASIS use, before rewriting the component definition.
+ when others =>
+ Error_Msg_N ("invalid subtype mark in subtype indication", S);
+ end case;
- else
- declare
- Desig : Entity_Id;
+ -- Size and Convention are always inherited from the base type
- begin
- Desig := Entity (Subtype_Indication (Type_Def));
+ Set_Size_Info (Def_Id, (Subtype_Mark_Id));
+ Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
- -- If the access definition is to the current record,
- -- the visible entity at this point is an incomplete
- -- type. Retrieve the full view to simplify ASIS queries
+ return Def_Id;
+ end if;
+ end Process_Subtype;
- if Ekind (Desig) = E_Incomplete_Type then
- Desig := Full_View (Desig);
- end if;
+ --------------------------------------------
+ -- Propagate_Default_Init_Cond_Attributes --
+ --------------------------------------------
- Set_Entity
- (Subtype_Mark (Access_Definition (Comp_Def)), Desig);
- end;
- end if;
+ procedure Propagate_Default_Init_Cond_Attributes
+ (From_Typ : Entity_Id;
+ To_Typ : Entity_Id;
+ Parent_To_Derivation : Boolean := False;
+ Private_To_Full_View : Boolean := False)
+ is
+ procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id);
+ -- Remove the default initial procedure (if any) from the rep chain of
+ -- type Typ.
- Rewrite (Comp_Def,
- Make_Component_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (Anon_Access, Loc)));
+ ----------------------------------------
+ -- Remove_Default_Init_Cond_Procedure --
+ ----------------------------------------
- if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
- Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
- else
- Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
+ procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id) is
+ Found : Boolean := False;
+ Prev : Entity_Id;
+ Subp : Entity_Id;
+
+ begin
+ Prev := Typ;
+ Subp := Subprograms_For_Type (Typ);
+ while Present (Subp) loop
+ if Is_Default_Init_Cond_Procedure (Subp) then
+ Found := True;
+ exit;
end if;
- Set_Is_Local_Anonymous_Access (Anon_Access);
+ Prev := Subp;
+ Subp := Subprograms_For_Type (Subp);
+ end loop;
+
+ if Found then
+ Set_Subprograms_For_Type (Prev, Subprograms_For_Type (Subp));
+ Set_Subprograms_For_Type (Subp, Empty);
end if;
+ end Remove_Default_Init_Cond_Procedure;
- Next (Comp);
- end loop;
+ -- Local variables
- if Present (Variant_Part (Comp_List)) then
- declare
- V : Node_Id;
- begin
- V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
- while Present (V) loop
- Check_Anonymous_Access_Components
- (Typ_Decl, Typ, Prev, Component_List (V));
- Next_Non_Pragma (V);
- end loop;
- end;
- end if;
- end Check_Anonymous_Access_Components;
+ Inherit_Procedure : Boolean := False;
- ----------------------------------
- -- Preanalyze_Assert_Expression --
- ----------------------------------
+ -- Start of processing for Propagate_Default_Init_Cond_Attributes
- procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is
begin
- In_Assertion_Expr := In_Assertion_Expr + 1;
- Preanalyze_Spec_Expression (N, T);
- In_Assertion_Expr := In_Assertion_Expr - 1;
- end Preanalyze_Assert_Expression;
+ if Has_Default_Init_Cond (From_Typ) then
- --------------------------------
- -- Preanalyze_Spec_Expression --
- --------------------------------
+ -- A derived type inherits the attributes from its parent type
- procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is
- Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
- begin
- In_Spec_Expression := True;
- Preanalyze_And_Resolve (N, T);
- In_Spec_Expression := Save_In_Spec_Expression;
- end Preanalyze_Spec_Expression;
+ if Parent_To_Derivation then
+ Set_Has_Inherited_Default_Init_Cond (To_Typ);
+
+ -- A full view shares the attributes with its private view
+
+ else
+ Set_Has_Default_Init_Cond (To_Typ);
+ end if;
+
+ Inherit_Procedure := True;
+
+ -- Due to the order of expansion, a derived private type is processed
+ -- by two routines which both attempt to set the attributes related
+ -- to pragma Default_Initial_Condition - Build_Derived_Type and then
+ -- Process_Full_View.
+
+ -- package Pack is
+ -- type Parent_Typ is private
+ -- with Default_Initial_Condition ...;
+ -- private
+ -- type Parent_Typ is ...;
+ -- end Pack;
+
+ -- with Pack; use Pack;
+ -- package Pack_2 is
+ -- type Deriv_Typ is private
+ -- with Default_Initial_Condition ...;
+ -- private
+ -- type Deriv_Typ is new Parent_Typ;
+ -- end Pack_2;
+
+ -- When Build_Derived_Type operates, it sets the attributes on the
+ -- full view without taking into account that the private view may
+ -- define its own default initial condition procedure. This becomes
+ -- apparent in Process_Full_View which must undo some of the work by
+ -- Build_Derived_Type and propagate the attributes from the private
+ -- to the full view.
+
+ if Private_To_Full_View then
+ Set_Has_Inherited_Default_Init_Cond (To_Typ, False);
+ Remove_Default_Init_Cond_Procedure (To_Typ);
+ end if;
+
+ -- A type must inherit the default initial condition procedure from a
+ -- parent type when the parent itself is inheriting the procedure or
+ -- when it is defining one. This circuitry is also used when dealing
+ -- with the private / full view of a type.
+
+ elsif Has_Inherited_Default_Init_Cond (From_Typ)
+ or (Parent_To_Derivation
+ and Present (Get_Pragma
+ (From_Typ, Pragma_Default_Initial_Condition)))
+ then
+ Set_Has_Inherited_Default_Init_Cond (To_Typ);
+ Inherit_Procedure := True;
+ end if;
+
+ if Inherit_Procedure
+ and then No (Default_Init_Cond_Procedure (To_Typ))
+ then
+ Set_Default_Init_Cond_Procedure
+ (To_Typ, Default_Init_Cond_Procedure (From_Typ));
+ end if;
+ end Propagate_Default_Init_Cond_Attributes;
-----------------------------
-- Record_Type_Declaration --
-- Normal case
- if Ada_Version < Ada_2005
- or else not Interface_Present (Def)
- then
+ if Ada_Version < Ada_2005 or else not Interface_Present (Def) then
if Limited_Present (Def) then
- Check_SPARK_Restriction ("limited is not allowed", N);
+ Check_SPARK_05_Restriction ("limited is not allowed", N);
end if;
if Abstract_Present (Def) then
- Check_SPARK_Restriction ("abstract is not allowed", N);
+ Check_SPARK_05_Restriction ("abstract is not allowed", N);
end if;
-- The flag Is_Tagged_Type might have already been set by
Tagged_Present (Def)
or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T));
- Set_Is_Tagged_Type (T, Is_Tagged);
- Set_Is_Limited_Record (T, Limited_Present (Def));
+ Set_Is_Limited_Record (T, Limited_Present (Def));
+
+ if Is_Tagged then
+ Set_Is_Tagged_Type (T, True);
+ Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams);
+ end if;
-- Type is abstract if full declaration carries keyword, or if
-- previous partial view did.
or else Abstract_Present (Def));
else
- Check_SPARK_Restriction ("interface is not allowed", N);
+ Check_SPARK_05_Restriction ("interface is not allowed", N);
Is_Tagged := True;
Analyze_Interface_Declaration (T, Def);
if Nkind (Ctxt) = N_Package_Body
and then Nkind (Parent (Ctxt)) = N_Compilation_Unit
then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("type should be defined in package specification", Typ);
elsif Nkind (Ctxt) /= N_Package_Specification
or else Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit
then
- Check_SPARK_Restriction
+ Check_SPARK_05_Restriction
("type should be defined in library unit package", Typ);
end if;
end;
or else Null_Present (Component_List (Def))
then
if not Is_Tagged_Type (T) then
- Check_SPARK_Restriction ("untagged record cannot be null", Def);
+ Check_SPARK_05_Restriction ("untagged record cannot be null", Def);
end if;
else
Analyze_Declarations (Component_Items (Component_List (Def)));
if Present (Variant_Part (Component_List (Def))) then
- Check_SPARK_Restriction ("variant part is not allowed", Def);
+ Check_SPARK_05_Restriction ("variant part is not allowed", Def);
Analyze (Variant_Part (Component_List (Def)));
end if;
end if;
end if;
end if;
- -- Complete both implicit base and declared first subtype entities
+ -- Complete both implicit base and declared first subtype entities. The
+ -- inheritance of the rep item chain ensures that SPARK-related pragmas
+ -- are not clobbered when the signed integer type acts as a full view of
+ -- a private type.
Set_Etype (Implicit_Base, Base_Typ);
- Set_Size_Info (Implicit_Base, (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_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
- Set_Ekind (T, E_Signed_Integer_Subtype);
- Set_Etype (T, Implicit_Base);
-
- Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
-
- 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);
+ Set_Ekind (T, E_Signed_Integer_Subtype);
+ Set_Etype (T, Implicit_Base);
+ Set_Size_Info (T, Implicit_Base);
+ Inherit_Rep_Item_Chain (T, 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;
projects / gcc.git / blobdiff