(Related_Nod : Node_Id;
N : Node_Id) return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (Related_Nod);
Anon_Type : Entity_Id;
Anon_Scope : Entity_Id;
Desig_Type : Entity_Id;
- Decl : Entity_Id;
Enclosing_Prot_Type : Entity_Id := Empty;
begin
Anon_Scope := Scope (Defining_Entity (Related_Nod));
end if;
- else
- -- For access formals, access components, and access discriminants,
- -- the scope is that of the enclosing declaration,
+ -- For an access type definition, if the current scope is a child
+ -- unit it is the scope of the type.
+
+ elsif Is_Compilation_Unit (Current_Scope) then
+ Anon_Scope := Current_Scope;
+
+ -- For access formals, access components, and access discriminants, the
+ -- scope is that of the enclosing declaration,
+ else
Anon_Scope := Scope (Current_Scope);
end if;
Set_Can_Use_Internal_Rep
(Anon_Type, not Always_Compatible_Rep_On_Target);
- -- If the anonymous access is associated with a protected operation
+ -- If the anonymous access is associated with a protected operation,
-- create a reference to it after the enclosing protected definition
-- because the itype will be used in the subsequent bodies.
-- proper Master for the created tasks.
if Nkind (Related_Nod) = N_Object_Declaration
- and then Expander_Active
+ and then Expander_Active
then
if Is_Interface (Desig_Type)
and then Is_Limited_Record (Desig_Type)
elsif Has_Task (Desig_Type)
and then Comes_From_Source (Related_Nod)
- and then not Restriction_Active (No_Task_Hierarchy)
then
- if not Has_Master_Entity (Current_Scope) then
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uMaster),
- Constant_Present => True,
- Object_Definition =>
- New_Reference_To (RTE (RE_Master_Id), Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- New_Reference_To (RTE (RE_Current_Master), Loc)));
-
- Insert_Before (Related_Nod, Decl);
- Analyze (Decl);
-
- Set_Master_Id (Anon_Type, Defining_Identifier (Decl));
- Set_Has_Master_Entity (Current_Scope);
- else
- Build_Master_Renaming (Related_Nod, Anon_Type);
- end if;
+ Build_Master_Entity (Defining_Identifier (Related_Nod));
+ Build_Master_Renaming (Anon_Type);
end if;
end if;
Set_Has_Task (T, False);
Set_Has_Controlled_Component (T, False);
- -- Initialize Associated_Collection explicitly to Empty, to avoid
+ -- Initialize field Finalization_Master explicitly to Empty, to avoid
-- problems where an incomplete view of this entity has been previously
-- established by a limited with and an overlaid version of this field
-- (Stored_Constraint) was initialized for the incomplete view.
-- This reset is performed in most cases except where the access type
-- has been created for the purposes of allocating or deallocating a
-- build-in-place object. Such access types have explicitly set pools
- -- and collections.
+ -- and finalization masters.
if No (Associated_Storage_Pool (T)) then
- Set_Associated_Collection (T, Empty);
+ Set_Finalization_Master (T, Empty);
end if;
-- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
(Tagged_Type => Tagged_Type,
Iface_Prim => Iface_Prim);
+ if No (Prim) and then Serious_Errors_Detected > 0 then
+ goto Continue;
+ end if;
+
pragma Assert (Present (Prim));
-- Ada 2012 (AI05-0197): If the name of the covering primitive
Set_Has_Delayed_Freeze (New_Subp);
end if;
+ <<Continue>>
Next_Elmt (Elmt);
end loop;
-- Start of processing for Analyze_Declarations
begin
- if SPARK_Mode or else Restriction_Check_Required (SPARK) then
+ if Restriction_Check_Required (SPARK) then
Check_Later_Vs_Basic_Declarations (L, During_Parsing => False);
end if;
D := First (L);
while Present (D) loop
- -- Package specification cannot contain a package declaration in
- -- SPARK.
+ -- Package spec cannot contain a package declaration in SPARK
if Nkind (D) = N_Package_Declaration
and then Nkind (Parent (L)) = N_Package_Specification
then
- Check_SPARK_Restriction ("package specification cannot contain "
- & "a package declaration", D);
+ Check_SPARK_Restriction
+ ("package specification cannot contain a package declaration",
+ D);
end if;
-- Complete analysis of declaration
if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then
Spec := Specification (Original_Node (Decl));
Sent := Defining_Unit_Name (Spec);
- Prag := Spec_PPC_List (Sent);
+
+ Prag := Spec_PPC_List (Contract (Sent));
while Present (Prag) loop
Analyze_PPC_In_Decl_Part (Prag, Sent);
Prag := Next_Pragma (Prag);
end loop;
+
+ Check_Subprogram_Contract (Sent);
+
+ Prag := Spec_TC_List (Contract (Sent));
+ while Present (Prag) loop
+ Analyze_TC_In_Decl_Part (Prag, Sent);
+ Prag := Next_Pragma (Prag);
+ end loop;
end if;
Next (Decl);
Set_Optimize_Alignment_Flags (Def_Id);
Check_Eliminated (Def_Id);
+ -- If the declaration is a completion and aspects are present, apply
+ -- them to the entity for the type which is currently the partial
+ -- view, but which is the one that will be frozen.
+
if Has_Aspects (N) then
- Analyze_Aspect_Specifications (N, Def_Id);
+ if Prev /= Def_Id then
+ Analyze_Aspect_Specifications (N, Prev);
+ else
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
end if;
end Analyze_Full_Type_Declaration;
-- 2. Those generated by the Expression
- -- 3. Those used to constrained the Object Definition with the
- -- expression constraints when it is unconstrained
+ -- 3. Those used to constrain the Object Definition with the
+ -- expression constraints when the definition is unconstrained.
-- They must be generated in this order to avoid order of elaboration
-- issues. Thus the first step (after entering the name) is to analyze
if Present (Prev_Entity)
and then
+
-- If the homograph is an implicit subprogram, it is overridden
-- by the current declaration.
Act_T := T;
- -- The object is in ALFA if-and-only-if its type is in ALFA and it is
- -- not aliased.
-
- if Is_In_ALFA (T) and then not Aliased_Present (N) then
- Set_Is_In_ALFA (Id);
- else
- Mark_Non_ALFA_Subprogram;
- end if;
-
-- These checks should be performed before the initialization expression
-- is considered, so that the Object_Definition node is still the same
-- as in source code.
if Is_Indefinite_Subtype (T) then
+ -- In SPARK, a declaration of unconstrained type is allowed
+ -- only for constants of type string.
+
+ if Is_String_Type (T) and then not Constant_Present (N) then
+ Check_SPARK_Restriction
+ ("declaration of object of unconstrained type not allowed",
+ N);
+ end if;
+
-- Nothing to do in deferred constant case
if Constant_Present (N) and then No (E) then
-- Case of initialization present
else
- -- Not allowed in Ada 83
+ -- Check restrictions in Ada 83
if not Constant_Present (N) then
+
+ -- Unconstrained variables not allowed in Ada 83 mode
+
if Ada_Version = Ada_83
and then Comes_From_Source (Object_Definition (N))
then
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
-
- -- Generate 'I' xref for object initialization at definition, only used
- -- for the local xref section used in ALFA mode.
-
- if ALFA_Mode and then Present (Expression (Original_Node (N))) then
- Generate_Reference (Id, Id, 'I');
- end if;
end Analyze_Object_Declaration;
---------------------------
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
+ Set_Has_Implicit_Dereference
+ (Id, Has_Implicit_Dereference (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
end if;
when Private_Kind =>
- Set_Ekind (Id, Subtype_Kind (Ekind (T)));
- Set_Has_Discriminants (Id, Has_Discriminants (T));
- Set_Is_Constrained (Id, Is_Constrained (T));
- Set_First_Entity (Id, First_Entity (T));
- Set_Last_Entity (Id, Last_Entity (T));
+ Set_Ekind (Id, Subtype_Kind (Ekind (T)));
+ Set_Has_Discriminants (Id, Has_Discriminants (T));
+ Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_First_Entity (Id, First_Entity (T));
+ Set_Last_Entity (Id, Last_Entity (T));
Set_Private_Dependents (Id, New_Elmt_List);
- Set_Is_Limited_Record (Id, Is_Limited_Record (T));
+ Set_Is_Limited_Record (Id, Is_Limited_Record (T));
+ Set_Has_Implicit_Dereference
+ (Id, Has_Implicit_Dereference (T));
Set_Has_Unknown_Discriminants
- (Id, Has_Unknown_Discriminants (T));
+ (Id, Has_Unknown_Discriminants (T));
Set_Known_To_Have_Preelab_Init
(Id, Known_To_Have_Preelab_Init (T));
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
- Set_Class_Wide_Type (Id, Class_Wide_Type (T));
+ Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Direct_Primitive_Operations (Id,
Direct_Primitive_Operations (T));
end if;
if Has_Discriminants (T) then
Set_Discriminant_Constraint
- (Id, Discriminant_Constraint (T));
+ (Id, Discriminant_Constraint (T));
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
elsif Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Set_Discriminant_Constraint
- (Id, Discriminant_Constraint (Full_View (T)));
+ (Id, Discriminant_Constraint (Full_View (T)));
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
-- This would seem semantically correct, but apparently
Nb_Index : Nat;
P : constant Node_Id := Parent (Def);
Priv : Entity_Id;
- T_In_ALFA : Boolean := True;
begin
if Nkind (Def) = N_Constrained_Array_Definition then
Check_SPARK_Restriction ("subtype mark required", Index);
end if;
- if Present (Etype (Index))
- and then not Is_In_ALFA (Etype (Index))
- then
- T_In_ALFA := False;
- end if;
-
-- Add a subtype declaration for each index of private array type
-- declaration whose etype is also private. For example:
if Present (Component_Typ) then
Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C');
+ 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);
end if;
- if Present (Element_Type)
- and then not Is_In_ALFA (Element_Type)
- then
- T_In_ALFA := False;
- end if;
-
-- Ada 2005 (AI-230): Access Definition case
else pragma Assert (Present (Access_Definition (Component_Def)));
- T_In_ALFA := False;
-
-- Indicate that the anonymous access type is created by the
-- array type declaration.
(Implicit_Base, Finalize_Storage_Only
(Element_Type));
- -- Final check for static bounds on array
-
- if not Has_Static_Array_Bounds (T) then
- T_In_ALFA := False;
- end if;
-
-- Unconstrained array case
else
Set_Component_Type (Base_Type (T), Element_Type);
Set_Packed_Array_Type (T, Empty);
- Set_Is_In_ALFA (T, T_In_ALFA);
if Aliased_Present (Component_Definition (Def)) then
Check_SPARK_Restriction
Parent_Base := Base_Type (Parent_Type);
end if;
+ -- AI05-0115 : if this is a derivation from a private type in some
+ -- other scope that may lead to invisible components for the derived
+ -- type, mark it accordingly.
+
+ if Is_Private_Type (Parent_Type) then
+ if Scope (Parent_Type) = Scope (Derived_Type) then
+ null;
+
+ elsif In_Open_Scopes (Scope (Parent_Type))
+ and then In_Private_Part (Scope (Parent_Type))
+ then
+ null;
+
+ else
+ Set_Has_Private_Ancestor (Derived_Type);
+ end if;
+
+ else
+ Set_Has_Private_Ancestor
+ (Derived_Type, Has_Private_Ancestor (Parent_Type));
+ end if;
+
-- Before we start the previously documented transformations, here is
-- little fix for size and alignment of tagged types. Normally when we
-- derive type D from type P, we copy the size and alignment of P as the
Set_Stored_Constraint
(Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
Replace_Components (Derived_Type, New_Decl);
+ Set_Has_Implicit_Dereference
+ (Derived_Type, Has_Implicit_Dereference (Parent_Type));
end if;
-- Insert the new derived type declaration
Set_Last_Entity
(Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
end if;
-
- -- Update the scope of anonymous access types of discriminants and other
- -- components, to prevent scope anomalies in gigi, when the derivation
- -- appears in a scope nested within that of the parent.
-
- declare
- D : Entity_Id;
-
- begin
- D := First_Entity (Derived_Type);
- while Present (D) loop
- if Ekind_In (D, E_Discriminant, E_Component) then
- if Is_Itype (Etype (D))
- and then Ekind (Etype (D)) = E_Anonymous_Access_Type
- then
- Set_Scope (Etype (D), Current_Scope);
- end if;
- end if;
-
- Next_Entity (D);
- end loop;
- end;
end Build_Derived_Record_Type;
------------------------
Set_First_Entity (Def_Id, First_Entity (T));
Set_Last_Entity (Def_Id, Last_Entity (T));
+ Set_Has_Implicit_Dereference
+ (Def_Id, Has_Implicit_Dereference (T));
-- If the subtype is the completion of a private declaration, there may
-- have been representation clauses for the partial view, and they must
-- The partial view of T may have been a private extension, for
-- which inherited functions dispatching on result are abstract.
-- If the full view is a null extension, there is no need for
- -- overriding in Ada2005, but wrappers need to be built for them
+ -- overriding in Ada 2005, but wrappers need to be built for them
-- (see exp_ch3, Build_Controlling_Function_Wrappers).
if Is_Null_Extension (T)
begin
E := Subp;
while Present (Alias (E)) loop
- Error_Msg_Sloc := Sloc (E);
- Error_Msg_NE
- ("\& has been inherited #", T, Subp);
+
+ -- Avoid reporting redundant errors on entities
+ -- inherited from interfaces
+
+ if Sloc (E) /= Sloc (T) then
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_NE
+ ("\& has been inherited #", T, Subp);
+ end if;
+
E := Alias (E);
end loop;
Error_Msg_Sloc := Sloc (E);
- Error_Msg_NE
- ("\& has been inherited from subprogram #",
- T, Subp);
+
+ -- AI05-0068: report if there is an overriding
+ -- non-abstract subprogram that is invisible.
+
+ if Is_Hidden (E)
+ and then not Is_Abstract_Subprogram (E)
+ then
+ Error_Msg_NE
+ ("\& subprogram# is not visible",
+ T, Subp);
+
+ else
+ Error_Msg_NE
+ ("\& has been inherited from subprogram #",
+ T, Subp);
+ end if;
end;
end if;
end if;
-- The controlling formal of Subp must be of mode "out",
-- "in out" or an access-to-variable to be overridden.
- -- Error message below needs rewording (remember comma
- -- in -gnatj mode) ???
-
if Ekind (First_Formal (Subp)) = E_In_Parameter
and then Ekind (Subp) /= E_Function
then
- if not Is_Predefined_Dispatching_Operation (Subp) then
- Error_Msg_NE
- ("first formal of & must be of mode `OUT`, " &
- "`IN OUT` or access-to-variable", T, Subp);
- Error_Msg_N
- ("\to be overridden by protected procedure or " &
- "entry (RM 9.4(11.9/2))", T);
+ if not Is_Predefined_Dispatching_Operation (Subp)
+ and then Is_Protected_Type
+ (Corresponding_Concurrent_Type (T))
+ then
+ Error_Msg_PT (T, Subp);
end if;
-- Some other kind of overriding failure
-- type, so we must be sure not to overwrite these entries.
declare
+ Append : Boolean;
Item : Node_Id;
Next_Item : Node_Id;
-- is not done, as that would create a circularity.
elsif Item /= First_Rep_Item (Priv) then
+ Append := True;
+
loop
Next_Item := Next_Rep_Item (Item);
exit when No (Next_Item);
Item := Next_Item;
+
+ -- If the private view has aspect specifications, the full view
+ -- inherits them. Since these aspects may already have been
+ -- attached to the full view during derivation, do not append
+ -- them if already present.
+
+ if Item = First_Rep_Item (Priv) then
+ Append := False;
+ exit;
+ end if;
end loop;
-- And link the private type items at the end of the chain
- Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
+ if Append then
+ Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
+ end if;
end if;
end;
Related_Id : Entity_Id;
Suffix : Character)
is
- T_Ent : Entity_Id := Entity (Subtype_Mark (SI));
+ -- Retrieve Base_Type to ensure getting to the concurrent type in the
+ -- case of a private subtype (needed when only doing semantic analysis).
+
+ T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI)));
T_Val : Entity_Id;
begin
C : constant Node_Id := Constraint (S);
begin
- -- By default, consider that the enumeration subtype is in ALFA if the
- -- entity of its subtype mark is in ALFA. This is reversed later if the
- -- range of the subtype is not static.
-
- if Nkind (Original_Node (Parent (Def_Id))) = N_Subtype_Declaration
- and then Is_In_ALFA (T)
- then
- Set_Is_In_ALFA (Def_Id);
- end if;
-
Set_Ekind (Def_Id, E_Enumeration_Subtype);
Set_First_Literal (Def_Id, First_Literal (Base_Type (T)));
C : constant Node_Id := Constraint (S);
begin
- -- By default, consider that the integer subtype is in ALFA if the
- -- entity of its subtype mark is in ALFA. This is reversed later if the
- -- range of the subtype is not static.
-
- if Nkind (Original_Node (Parent (Def_Id))) = N_Subtype_Declaration
- and then Is_In_ALFA (T)
- then
- Set_Is_In_ALFA (Def_Id);
- end if;
-
Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T);
if Is_Modular_Integer_Type (T) then
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
-- Check for case of a derived subprogram for the instantiation of a
-- formal derived tagged type, if so mark the subprogram as dispatching
- -- and inherit the dispatching attributes of the parent subprogram. The
+ -- and inherit the dispatching attributes of the actual subprogram. The
-- derived subprogram is effectively renaming of the actual subprogram,
-- so it needs to have the same attributes as the actual.
if Present (Actual_Subp)
- and then Is_Dispatching_Operation (Parent_Subp)
+ and then Is_Dispatching_Operation (Actual_Subp)
then
Set_Is_Dispatching_Operation (New_Subp);
- if Present (DTC_Entity (Parent_Subp)) then
- Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp));
- Set_DT_Position (New_Subp, DT_Position (Parent_Subp));
+ if Present (DTC_Entity (Actual_Subp)) then
+ Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
+ Set_DT_Position (New_Subp, DT_Position (Actual_Subp));
end if;
end if;
Type_Conformant (Subp, Act_Subp,
Skip_Controlling_Formals => True)))
then
- pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual));
+ pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual,
+ Use_Full_View => True));
-- Remember that we need searching for all pending primitives
Set_Enum_Esize (T);
Set_Enum_Pos_To_Rep (T, Empty);
- -- Enumeration type is in ALFA only if it is not a character type
-
- if not Is_Character_Type (T) then
- Set_Is_In_ALFA (T);
- end if;
-
-- Set Discard_Names if configuration pragma set, or if there is
-- a parameterless pragma in the current declarative region
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
+ -- Preserve aspect and iterator flags that may have been set on
+ -- the partial view.
+
+ Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
+ Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
+
-- If no error, propagate freeze_node from private to full view.
-- It may have been generated for an early operational item.
end if;
end if;
+ if Present (Prev)
+ and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration
+ and then Present (Premature_Use (Parent (Prev)))
+ then
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_N
+ ("\full declaration #", Premature_Use (Parent (Prev)));
+ end if;
+
return New_Id;
end if;
end Find_Type_Name;
elsif Def_Kind = N_Access_Definition then
T := Access_Definition (Related_Nod, Obj_Def);
- Set_Is_Local_Anonymous_Access (T);
+
+ Set_Is_Local_Anonymous_Access
+ (T,
+ V => (Ada_Version < Ada_2012)
+ or else (Nkind (P) /= N_Object_Declaration)
+ or else Is_Library_Level_Entity (Defining_Identifier (P)));
-- Otherwise, the object definition is just a subtype_mark
elsif No (Real_Range_Specification (Def)) then
Error_Msg_Uint_1 := Max_Digs_Val;
Error_Msg_N ("types with more than ^ digits need range spec "
- & "('R'M 3.5.7(6))", Digs);
+ & "(RM 3.5.7(6))", Digs);
end if;
end;
end if;
Plain_Discrim : Boolean := False;
Stored_Discrim : Boolean := False)
is
+ procedure Set_Anonymous_Type (Id : Entity_Id);
+ -- Id denotes the entity of an access discriminant or anonymous
+ -- access component. Set the type of Id to either the same type of
+ -- Old_C or create a new one depending on whether the parent and
+ -- the child types are in the same scope.
+
+ ------------------------
+ -- Set_Anonymous_Type --
+ ------------------------
+
+ procedure Set_Anonymous_Type (Id : Entity_Id) is
+ Old_Typ : constant Entity_Id := Etype (Old_C);
+
+ begin
+ if Scope (Parent_Base) = Scope (Derived_Base) then
+ Set_Etype (Id, Old_Typ);
+
+ -- The parent and the derived type are in two different scopes.
+ -- Reuse the type of the original discriminant / component by
+ -- copying it in order to preserve all attributes.
+
+ else
+ declare
+ Typ : constant Entity_Id := New_Copy (Old_Typ);
+
+ begin
+ Set_Etype (Id, Typ);
+
+ -- Since we do not generate component declarations for
+ -- inherited components, associate the itype with the
+ -- derived type.
+
+ Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base));
+ Set_Scope (Typ, Derived_Base);
+ end;
+ end if;
+ end Set_Anonymous_Type;
+
+ -- Local variables and constants
+
New_C : constant Entity_Id := New_Copy (Old_C);
- Discrim : Entity_Id;
Corr_Discrim : Entity_Id;
+ Discrim : Entity_Id;
+
+ -- Start of processing for Inherit_Component
begin
pragma Assert (not Is_Tagged or else not Stored_Discrim);
Set_Original_Record_Component (New_C, New_C);
end if;
+ -- Set the proper type of an access discriminant
+
+ if Ekind (New_C) = E_Discriminant
+ and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type
+ then
+ Set_Anonymous_Type (New_C);
+ end if;
+
-- If we have inherited a component then see if its Etype contains
-- references to Parent_Base discriminants. In this case, replace
-- these references with the constraints given in Discs. We do not
-- transformation in some error situations.
if Ekind (New_C) = E_Component then
- if (Is_Private_Type (Derived_Base)
- and then not Is_Generic_Type (Derived_Base))
+
+ -- Set the proper type of an anonymous access component
+
+ if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then
+ Set_Anonymous_Type (New_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));
Set_Etype
(New_C,
Constrain_Component_Type
- (Old_C, Derived_Base, N, Parent_Base, Discs));
+ (Old_C, Derived_Base, N, Parent_Base, Discs));
end if;
end if;
elsif not Comes_From_Source (Original_Comp) then
return True;
- -- If we are in the body of an instantiation, the component is visible
- -- even when the parent type (possibly defined in an enclosing unit or
- -- in a parent unit) might not.
-
- elsif In_Instance_Body then
- return True;
-
-- Discriminants are always visible
elsif Ekind (Original_Comp) = E_Discriminant
then
return True;
+ -- If we are in the body of an instantiation, the component is visible
+ -- if the parent type is non-private, or in an enclosing scope. The
+ -- scope stack is not present when analyzing an instance body, so we
+ -- must inspect the chain of scopes explicitly.
+
+ elsif In_Instance_Body then
+ if not Is_Private_Type (Scope (C)) then
+ return True;
+
+ else
+ declare
+ S : Entity_Id;
+
+ begin
+ S := Current_Scope;
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if S = Type_Scope then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end;
+ end if;
+
-- If the component has been declared in an ancestor which is currently
-- a private type, then it is not visible. The same applies if the
-- component's containing type is not in an open scope and the original
-- function calls. The function call may have been given in prefixed
-- notation, in which case the original node is an indexed component.
-- If the function is parameterless, the original node was an explicit
- -- dereference.
+ -- dereference. The function may also be parameterless, in which case
+ -- the source node is just an identifier.
case Nkind (Original_Node (Exp)) is
when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
return True;
+ when N_Identifier =>
+ return Present (Entity (Original_Node (Exp)))
+ and then Ekind (Entity (Original_Node (Exp))) = E_Function;
+
when N_Qualified_Expression =>
return
OK_For_Limited_Init_In_05
when N_Attribute_Reference =>
return Attribute_Name (Original_Node (Exp)) = Name_Input;
+ -- For a conditional expression, all dependent expressions must be
+ -- legal constructs.
+
+ when N_Conditional_Expression =>
+ declare
+ Then_Expr : constant Node_Id :=
+ Next (First (Expressions (Original_Node (Exp))));
+ Else_Expr : constant Node_Id := Next (Then_Expr);
+ begin
+ return OK_For_Limited_Init_In_05 (Typ, Then_Expr)
+ and then OK_For_Limited_Init_In_05 (Typ, Else_Expr);
+ end;
+
+ when N_Case_Expression =>
+ declare
+ Alt : Node_Id;
+
+ begin
+ Alt := First (Alternatives (Original_Node (Exp)));
+ while Present (Alt) loop
+ if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then
+ return False;
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ return True;
+ end;
+
when others =>
return False;
end case;
-- worst, and therefore defaults are not allowed if the parent is
-- a generic formal private type (see ACATS B370001).
- if Is_Access_Type (Discr_Type) then
+ if Is_Access_Type (Discr_Type) and then Default_Present then
if Ekind (Discr_Type) /= E_Anonymous_Access_Type
- or else not Default_Present
or else Is_Limited_Record (Current_Scope)
or else Is_Concurrent_Type (Current_Scope)
or else Is_Concurrent_Record_Type (Current_Scope)
and then (Is_Limited_Type (Full_T)
or else Is_Limited_Composite (Full_T))
then
- Error_Msg_N
- ("completion of nonlimited type cannot be limited", Full_T);
- Explain_Limited_Type (Full_T, Full_T);
+ 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)
-- 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 private system child.
+ -- 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);
-- 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).
+ -- of the interface type (AARM 7.3 (7.3/2)).
Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
-- 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 Ada2012 the
+ -- 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,
return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
end if;
- -- Remaining processing depends on type
+ -- 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 (Subtype_Mark_Id) is
+ case Ekind (Base_Type (Subtype_Mark_Id)) is
when Access_Kind =>
Constrain_Access (Def_Id, S, Related_Nod);
-- do not know the exact end points at the time of the declaration. This
-- is true for three reasons:
- -- A size clause may affect the fudging of the end-points
- -- A small clause may affect the values of the end-points
- -- We try to include the end-points if it does not affect the size
+ -- A size clause may affect the fudging of the end-points.
+ -- A small clause may affect the values of the end-points.
+ -- We try to include the end-points if it does not affect the size.
- -- This means that the actual end-points must be established at the point
- -- when the type is frozen. Meanwhile, we first narrow the range as
- -- permitted (so that it will fit if necessary in a small specified size),
- -- and then build a range subtree with these narrowed bounds.
-
- -- Set_Fixed_Range constructs the range from real literal values, and sets
- -- the range as the Scalar_Range of the given fixed-point type entity.
+ -- This means that the actual end-points must be established at the
+ -- point when the type is frozen. Meanwhile, we first narrow the range
+ -- as permitted (so that it will fit if necessary in a small specified
+ -- size), and then build a range subtree with these narrowed bounds.
+ -- Set_Fixed_Range constructs the range from real literal values, and
+ -- sets the range as the Scalar_Range of the given fixed-point type entity.
-- The parent of this range is set to point to the entity so that it is
-- properly hooked into the tree (unlike normal Scalar_Range entries for
begin
Set_Scalar_Range (E, S);
Set_Parent (S, E);
+
+ -- Before the freeze point, the bounds of a fixed point are universal
+ -- and carry the corresponding type.
+
+ Set_Etype (Low_Bound (S), Universal_Real);
+ Set_Etype (High_Bound (S), Universal_Real);
end Set_Fixed_Range;
----------------------------------
Set_Ekind (Def_Id, E_Void);
Process_Range_Expr_In_Decl (R, Subt);
Set_Ekind (Def_Id, Kind);
-
- -- In ALFA, all subtypes should have a static range
-
- if Nkind (R) = N_Range
- and then not Is_Static_Range (R)
- then
- Set_Is_In_ALFA (Def_Id, False);
- end if;
end Set_Scalar_Range_For_Subtype;
--------------------------------------------------------
-- Complete both implicit base and declared first subtype entities
Set_Etype (Implicit_Base, Base_Typ);
- Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
Set_Size_Info (Implicit_Base, (Base_Typ));
Set_RM_Size (Implicit_Base, RM_Size (Base_Typ));
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
Set_Ekind (T, E_Signed_Integer_Subtype);
Set_Etype (T, Implicit_Base);
+ -- In formal verification mode, restrict the base type's range to the
+ -- minimum allowed by RM 3.5.4, namely the smallest symmetric range
+ -- around zero with a possible extra negative value that contains the
+ -- subtype range. Keep Size, RM_Size and First_Rep_Item info, which
+ -- should not be relied upon in formal verification.
+
+ if Strict_Alfa_Mode then
+ declare
+ Sym_Hi_Val : Uint;
+ Sym_Lo_Val : Uint;
+ Dloc : constant Source_Ptr := Sloc (Def);
+ Lbound : Node_Id;
+ Ubound : Node_Id;
+ Bounds : Node_Id;
+
+ begin
+ -- If the subtype range is empty, the smallest base type range
+ -- is the symmetric range around zero containing Lo_Val and
+ -- Hi_Val.
+
+ if UI_Gt (Lo_Val, Hi_Val) then
+ Sym_Hi_Val := UI_Max (UI_Abs (Lo_Val), UI_Abs (Hi_Val));
+ Sym_Lo_Val := UI_Negate (Sym_Hi_Val);
+
+ -- Otherwise, if the subtype range is not empty and Hi_Val has
+ -- the largest absolute value, Hi_Val is non negative and the
+ -- smallest base type range is the symmetric range around zero
+ -- containing Hi_Val.
+
+ elsif UI_Le (UI_Abs (Lo_Val), UI_Abs (Hi_Val)) then
+ Sym_Hi_Val := Hi_Val;
+ Sym_Lo_Val := UI_Negate (Hi_Val);
+
+ -- Otherwise, the subtype range is not empty, Lo_Val has the
+ -- strictly largest absolute value, Lo_Val is negative and the
+ -- smallest base type range is the symmetric range around zero
+ -- with an extra negative value Lo_Val.
+
+ else
+ Sym_Lo_Val := Lo_Val;
+ Sym_Hi_Val := UI_Sub (UI_Negate (Lo_Val), Uint_1);
+ end if;
+
+ Lbound := Make_Integer_Literal (Dloc, Sym_Lo_Val);
+ Ubound := Make_Integer_Literal (Dloc, Sym_Hi_Val);
+ Set_Is_Static_Expression (Lbound);
+ Set_Is_Static_Expression (Ubound);
+ Analyze_And_Resolve (Lbound, Any_Integer);
+ Analyze_And_Resolve (Ubound, Any_Integer);
+
+ Bounds := Make_Range (Dloc, Lbound, Ubound);
+ Set_Etype (Bounds, Base_Typ);
+
+ Set_Scalar_Range (Implicit_Base, Bounds);
+ end;
+
+ else
+ Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
+ end if;
+
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_Is_In_ALFA (T);
end Signed_Integer_Type_Declaration;
end Sem_Ch3;
OSDN Git Service
