-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
(T : Entity_Id;
Def : Node_Id;
Derived_Def : Boolean := False) return Elist_Id;
- -- Validate discriminant constraints, and return the list of the
- -- constraints in order of discriminant declarations. T is the
- -- discriminated unconstrained type. Def is the N_Subtype_Indication node
- -- where the discriminants constraints for T are specified. Derived_Def is
- -- True if we are building the discriminant constraints in a derived type
- -- definition of the form "type D (...) is new T (xxx)". In this case T is
- -- the parent type and Def is the constraint "(xxx)" on T and this routine
- -- sets the Corresponding_Discriminant field of the discriminants in the
- -- derived type D to point to the corresponding discriminants in the parent
- -- type T.
+ -- Validate discriminant constraints and return the list of the constraints
+ -- in order of discriminant declarations, where T is the discriminated
+ -- unconstrained type. Def is the N_Subtype_Indication node where the
+ -- discriminants constraints for T are specified. Derived_Def is True
+ -- when building the discriminant constraints in a derived type definition
+ -- of the form "type D (...) is new T (xxx)". In this case T is the parent
+ -- type and Def is the constraint "(xxx)" on T and this routine sets the
+ -- Corresponding_Discriminant field of the discriminants in the derived
+ -- type D to point to the corresponding discriminants in the parent type T.
procedure Build_Discriminated_Subtype
(T : 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;
if Nkind (Related_Nod) = N_Object_Declaration
or else Nkind (Related_Nod) = N_Access_Function_Definition
then
- Anon_Type :=
- Create_Itype
- (E_Anonymous_Access_Type, Related_Nod,
- Scope_Id => Current_Scope);
+ Anon_Scope := Current_Scope;
-- For the anonymous function result case, retrieve the scope of the
-- function specification's associated entity rather than using the
elsif Nkind (Related_Nod) = N_Function_Specification
and then Nkind (Parent (N)) /= N_Parameter_Specification
then
- Anon_Type :=
- Create_Itype
- (E_Anonymous_Access_Type,
- Related_Nod,
- Scope_Id => Scope (Defining_Entity (Related_Nod)));
+ -- If the current scope is a protected type, the anonymous access
+ -- is associated with one of the protected operations, and must
+ -- be available in the scope that encloses the protected declaration.
+ -- Otherwise the type is is in the scope enclosing the subprogram.
+
+ if Ekind (Current_Scope) = E_Protected_Type then
+ Anon_Scope := Scope (Scope (Defining_Entity (Related_Nod)));
+ else
+ 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,
- Anon_Type :=
- Create_Itype
- (E_Anonymous_Access_Type, Related_Nod,
- Scope_Id => Scope (Current_Scope));
+ Anon_Scope := Scope (Current_Scope);
end if;
+ Anon_Type :=
+ Create_Itype
+ (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope);
+
if All_Present (N)
and then Ada_Version >= Ada_05
then
(Anon_Type, E_Anonymous_Access_Subprogram_Type);
end if;
+ -- 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.
+
+ if Ekind (Current_Scope) = E_Protected_Type then
+ Build_Itype_Reference (Anon_Type, Parent (Current_Scope));
+ end if;
+
return Anon_Type;
end if;
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
-- Ada 2005 (AI-50217): Propagate the attribute that indicates that the
- -- designated type comes from the limited view (for back-end purposes).
+ -- designated type comes from the limited view.
Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
D_Ityp := Associated_Node_For_Itype (Desig_Type);
while Nkind (D_Ityp) /= N_Full_Type_Declaration
+ and then Nkind (D_Ityp) /= N_Private_Type_Declaration
+ and then Nkind (D_Ityp) /= N_Private_Extension_Declaration
and then Nkind (D_Ityp) /= N_Procedure_Specification
and then Nkind (D_Ityp) /= N_Function_Specification
and then Nkind (D_Ityp) /= N_Object_Declaration
if Nkind (T_Def) = N_Access_Function_Definition then
if Nkind (Result_Definition (T_Def)) = N_Access_Definition then
- Set_Etype
- (Desig_Type,
- Access_Definition (T_Def, Result_Definition (T_Def)));
+
+ declare
+ Acc : constant Node_Id := Result_Definition (T_Def);
+
+ begin
+ if Present (Access_To_Subprogram_Definition (Acc))
+ and then
+ Protected_Present (Access_To_Subprogram_Definition (Acc))
+ then
+ Set_Etype
+ (Desig_Type,
+ Replace_Anonymous_Access_To_Protected_Subprogram
+ (T_Def));
+
+ else
+ Set_Etype
+ (Desig_Type,
+ Access_Definition (T_Def, Result_Definition (T_Def)));
+ end if;
+ end;
+
else
Analyze (Result_Definition (T_Def));
Set_Etype (Desig_Type, Entity (Result_Definition (T_Def)));
end if;
if Present (Formals) then
- New_Scope (Desig_Type);
+ Push_Scope (Desig_Type);
Process_Formals (Formals, Parent (T_Def));
-- A bit of a kludge here, End_Scope requires that the parent
-- The return type and/or any parameter type may be incomplete. Mark
-- the subprogram_type as depending on the incomplete type, so that
- -- it can be updated when the full type declaration is seen.
+ -- it can be updated when the full type declaration is seen. This
+ -- only applies to incomplete types declared in some enclosing scope,
+ -- not to limited views from other packages.
if Present (Formals) then
Formal := First_Formal (Desig_Type);
Error_Msg_N ("functions can only have IN parameters", Formal);
end if;
- if Ekind (Etype (Formal)) = E_Incomplete_Type then
+ if Ekind (Etype (Formal)) = E_Incomplete_Type
+ and then In_Open_Scopes (Scope (Etype (Formal)))
+ then
Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal)));
Set_Has_Delayed_Freeze (Desig_Type);
end if;
Init_Size_Align (T);
end if;
- Set_Is_Access_Constant (T, Constant_Present (Def));
-
Desig := Designated_Type (T);
-- If designated type is an imported tagged type, indicate that the
-- is available, use it as the designated type of the access type, so
-- that the back-end gets a usable entity.
- declare
- N_Desig : Entity_Id;
-
- begin
- if From_With_Type (Desig)
- and then Ekind (Desig) /= E_Access_Type
- then
- Set_From_With_Type (T);
-
- if Is_Incomplete_Type (Desig) then
- N_Desig := Non_Limited_View (Desig);
-
- else pragma Assert (Ekind (Desig) = E_Class_Wide_Type);
- if From_With_Type (Etype (Desig)) then
- N_Desig := Non_Limited_View (Etype (Desig));
- else
- N_Desig := Etype (Desig);
- end if;
- end if;
-
- pragma Assert (Present (N_Desig));
- Set_Directly_Designated_Type (T, N_Desig);
- end if;
- end;
+ if From_With_Type (Desig)
+ and then Ekind (Desig) /= E_Access_Type
+ then
+ Set_From_With_Type (T);
+ end if;
-- Note that Has_Task is always false, since the access type itself
-- is not a task type. See Einfo for more description on this point.
Set_Analyzed (Decl);
Set_Ekind (Tag, E_Component);
- Set_Is_Limited_Record (Tag);
Set_Is_Tag (Tag);
+ Set_Is_Aliased (Tag);
+ Set_Related_Interface (Tag, Iface);
Init_Component_Location (Tag);
pragma Assert (Is_Frozen (Iface));
Set_Analyzed (Decl);
Set_Ekind (Offset, E_Component);
+ Set_Is_Aliased (Offset);
+ Set_Related_Interface (Offset, Iface);
Init_Component_Location (Offset);
Insert_After (Last_Tag, Decl);
Last_Tag := Decl;
-- Start of processing for Add_Interface_Tag_Components
begin
+ if not RTE_Available (RE_Interface_Tag) then
+ Error_Msg
+ ("(Ada 2005) interface types not supported by this run-time!",
+ Sloc (N));
+ return;
+ end if;
+
if Ekind (Typ) /= E_Record_Type
- or else not RTE_Available (RE_Interface_Tag)
or else (Is_Concurrent_Record_Type (Typ)
and then Is_Empty_List (Abstract_Interface_List (Typ)))
or else (not Is_Concurrent_Record_Type (Typ)
Comp := First (L);
while Present (Comp) loop
- if Is_Tag (Defining_Identifier (Comp)) then
+ if Nkind (Comp) = N_Component_Declaration
+ and then Is_Tag (Defining_Identifier (Comp))
+ then
Last_Tag := Comp;
end if;
procedure Analyze_Component_Declaration (N : Node_Id) is
Id : constant Entity_Id := Defining_Identifier (N);
+ E : constant Node_Id := Expression (N);
T : Entity_Id;
P : Entity_Id;
function Contains_POC (Constr : Node_Id) return Boolean is
begin
+ -- Prevent cascaded errors.
+
+ if Error_Posted (Constr) then
+ return False;
+ end if;
+
case Nkind (Constr) is
when N_Attribute_Reference =>
- return Attribute_Name (Constr) = Name_Access
- and
- Prefix (Constr) = Scope (Entity (Prefix (Constr)));
+ return
+ Attribute_Name (Constr) = Name_Access
+ and then Prefix (Constr) = Scope (Entity (Prefix (Constr)));
when N_Discriminant_Association =>
return Denotes_Discriminant (Expression (Constr));
-- "Handling of Default and Per-Object Expressions" in the spec of
-- package Sem).
- if Present (Expression (N)) then
- Analyze_Per_Use_Expression (Expression (N), T);
- Check_Initialization (T, Expression (N));
+ if Present (E) then
+ Analyze_Per_Use_Expression (E, T);
+ Check_Initialization (T, E);
if Ada_Version >= Ada_05
- and then Is_Access_Type (T)
and then Ekind (T) = E_Anonymous_Access_Type
then
-- Check RM 3.9.2(9): "if the expected type for an expression is
and then
Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type
and then
- Ekind (Directly_Designated_Type (Etype (Expression (N)))) =
- E_Class_Wide_Type
+ Ekind (Directly_Designated_Type (Etype (E))) =
+ E_Class_Wide_Type
then
Error_Msg_N
("access to specific tagged type required ('R'M 3.9.2(9))",
- Expression (N));
+ E);
end if;
-- (Ada 2005: AI-230): Accessibility check for anonymous
-- components
- -- Missing barrier Ada_Version >= Ada_05???
+ if Type_Access_Level (Etype (E)) > Type_Access_Level (T) then
+ Error_Msg_N
+ ("expression has deeper access level than component " &
+ "('R'M 3.10.2 (12.2))", E);
+ end if;
+
+ -- The initialization expression is a reference to an access
+ -- discriminant. The type of the discriminant is always deeper
+ -- than any access type.
- if Type_Access_Level (Etype (Expression (N))) >
- Type_Access_Level (T)
+ if Ekind (Etype (E)) = E_Anonymous_Access_Type
+ and then Is_Entity_Name (E)
+ and then Ekind (Entity (E)) = E_In_Parameter
+ and then Present (Discriminal_Link (Entity (E)))
then
Error_Msg_N
- ("expression has deeper access level than component " &
- "('R'M 3.10.2 (12.2))", Expression (N));
+ ("discriminant has deeper accessibility level than target",
+ E);
end if;
end if;
end if;
Set_Primitive_Operations (T, New_Elmt_List);
end if;
- New_Scope (T);
+ Push_Scope (T);
Set_Stored_Constraint (T, No_Elist);
-----------------------------------
procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
+ CW : constant Entity_Id := Class_Wide_Type (T);
+
begin
Set_Is_Tagged_Type (T);
or else Protected_Present (Def)
or else Synchronized_Present (Def));
- -- Type is abstract if full declaration carries keyword, or if
- -- previous partial view did.
+ -- Type is abstract if full declaration carries keyword, or if previous
+ -- partial view did.
Set_Is_Abstract_Type (T);
Set_Is_Interface (T);
- Set_Is_Limited_Interface (T, Limited_Present (Def));
+ -- Type is a limited interface if it includes the keyword limited, task,
+ -- protected, or synchronized.
+
+ Set_Is_Limited_Interface
+ (T, Limited_Present (Def)
+ or else Protected_Present (Def)
+ or else Synchronized_Present (Def)
+ or else Task_Present (Def));
+
Set_Is_Protected_Interface (T, Protected_Present (Def));
- Set_Is_Synchronized_Interface (T, Synchronized_Present (Def));
Set_Is_Task_Interface (T, Task_Present (Def));
+
+ -- Type is a synchronized interface if it includes the keyword task,
+ -- protected, or synchronized.
+
+ Set_Is_Synchronized_Interface
+ (T, Synchronized_Present (Def)
+ or else Protected_Present (Def)
+ or else Task_Present (Def));
+
Set_Abstract_Interfaces (T, New_Elmt_List);
Set_Primitive_Operations (T, New_Elmt_List);
+
+ -- Complete the decoration of the class-wide entity if it was already
+ -- built (ie. during the creation of the limited view)
+
+ if Present (CW) then
+ Set_Is_Interface (CW);
+ Set_Is_Limited_Interface (CW, Is_Limited_Interface (T));
+ Set_Is_Protected_Interface (CW, Is_Protected_Interface (T));
+ Set_Is_Synchronized_Interface (CW, Is_Synchronized_Interface (T));
+ Set_Is_Task_Interface (CW, Is_Task_Interface (T));
+ end if;
end Analyze_Interface_Declaration;
-----------------------------
-- Process initialization expression if present and not in error
if Present (E) and then E /= Error then
+ Mark_Static_Coextensions (E);
Analyze (E);
-- In case of errors detected in the analysis of the expression,
if not Assignment_OK (N) then
Check_Initialization (T, E);
end if;
+
Check_Unset_Reference (E);
-- If this is a variable, then set current value
Set_Primitive_Operations
(Id, Primitive_Operations (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
+
+ if Is_Interface (T) then
+ Set_Is_Interface (Id);
+ Set_Is_Limited_Interface (Id, Is_Limited_Interface (T));
+ end if;
end if;
when Private_Kind =>
Set_First_Private_Entity (Id, First_Private_Entity (T));
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Is_Tagged_Type (Id, Is_Tagged_Type (T));
Set_Last_Entity (Id, Last_Entity (T));
if Has_Discriminants (T) then
Set_Is_Immediately_Visible (Id, True);
Set_Depends_On_Private (Id, Has_Private_Component (T));
+ if Is_Interface (T) then
+ Set_Is_Interface (Id);
+ end if;
+
if Present (Generic_Parent_Type (N))
and then
(Nkind
/= N_Formal_Private_Type_Definition)
then
if Is_Tagged_Type (Id) then
- if Is_Class_Wide_Type (Id) then
+
+ -- If this is a generic actual subtype for a synchronized type,
+ -- the primitive operations are those of the corresponding record
+ -- for which there is a separate subtype declaration.
+
+ if Is_Concurrent_Type (Id) then
+ null;
+ elsif Is_Class_Wide_Type (Id) then
Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T));
else
Derive_Subprograms (Generic_Parent_Type (N), Id, T);
Discr_Name := Name (N);
Analyze (Discr_Name);
- if Ekind (Entity (Discr_Name)) /= E_Discriminant then
+ if Etype (Discr_Name) = Any_Type then
+
+ -- Prevent cascaded errors
+
+ return;
+
+ elsif Ekind (Entity (Discr_Name)) /= E_Discriminant then
Error_Msg_N ("invalid discriminant name in variant part", Discr_Name);
end if;
and then not Is_Itype (Element_Type)
then
Error_Msg_N
- ("null-exclusion cannot be applied to a null excluding type",
+ ("`NOT NULL` not allowed (null already excluded)",
Subtype_Indication (Component_Definition (Def)));
end if;
end if;
end if;
end if;
+ -- A syntax error in the declaration itself may lead to an empty
+ -- index list, in which case do a minimal patch.
+
+ if No (First_Index (T)) then
+ Error_Msg_N ("missing index definition in array type declaration", T);
+
+ declare
+ Indices : constant List_Id :=
+ New_List (New_Occurrence_Of (Any_Id, Sloc (T)));
+
+ begin
+ Set_Discrete_Subtype_Definitions (Def, Indices);
+ Set_First_Index (T, First (Indices));
+ return;
+ end;
+ end if;
+
-- Create a concatenation operator for the new type. Internal
-- array types created for packed entities do not need such, they
-- are compatible with the user-defined type.
Comp := Parameter_Type (N);
Acc := Comp;
+ when N_Access_Function_Definition =>
+ Comp := Result_Definition (N);
+ Acc := Comp;
+
when N_Object_Declaration =>
Comp := Object_Definition (N);
Acc := Comp;
Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
Set_Etype (Defining_Identifier (N), Anon);
+ elsif Nkind (N) = N_Access_Function_Definition then
+ Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
+
else
Rewrite (Comp,
Make_Component_Definition (Loc,
-- Temporarily remove the current scope from the stack to add the new
-- declarations to the enclosing scope
- if Nkind (N) /= N_Object_Declaration then
- Scope_Stack.Decrement_Last;
+ if Nkind (N) = N_Object_Declaration
+ or else Nkind (N) = N_Access_Function_Definition
+ then
Analyze (Decl);
- Scope_Stack.Append (Curr_Scope);
+
else
+ Scope_Stack.Decrement_Last;
Analyze (Decl);
+ Set_Is_Itype (Anon);
+ Scope_Stack.Append (Curr_Scope);
end if;
Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type);
end if;
if Present (Discriminant_Specifications (N)) then
- New_Scope (Derived_Type);
+ Push_Scope (Derived_Type);
Check_Or_Process_Discriminants (N, Derived_Type);
End_Scope;
-- be limited in that case the type must be explicitly declared as
-- limited.
- Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
- Set_Is_Limited_Record (Derived_Type,
- Limited_Present (Type_Def)
- or else (Is_Limited_Record (Parent_Type)
- and then not Is_Interface (Parent_Type)));
+ Set_Is_Limited_Record
+ (Derived_Type,
+ Limited_Present (Type_Def)
+ or else (Is_Limited_Record (Parent_Type)
+ and then not Is_Interface (Parent_Type)));
-- STEP 2a: process discriminants of derived type if any
- New_Scope (Derived_Type);
+ Push_Scope (Derived_Type);
if Discriminant_Specs then
Set_Has_Unknown_Discriminants (Derived_Type, False);
Set_Is_Private_Composite
(Derived_Type, Is_Private_Composite (Parent_Type));
- if not Is_Limited_Record (Derived_Type) then
- Set_Is_Limited_Record
- (Derived_Type,
- Is_Limited_Record (Parent_Type)
- and then not Is_Interface (Parent_Type));
- end if;
-
-- Fields inherited from the Parent_Base
Set_Has_Controlled_Component
(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 (D) = E_Discriminant
+ or else Ekind (D) = 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;
------------------------
elsif not For_Access then
Set_Cloned_Subtype (Def_Id, T);
end if;
+
+ -- Handle subtypes associated with statically allocated dispatch
+ -- tables.
+
+ if Static_Dispatch_Tables
+ and then VM_Target = No_VM
+ and then RTU_Loaded (Ada_Tags)
+ and then (T = RTE (RE_Dispatch_Table_Wrapper)
+ or else
+ T = RTE (RE_Type_Specific_Data))
+ then
+ Set_Size_Known_At_Compile_Time (Def_Id);
+ end if;
end if;
end Build_Discriminated_Subtype;
-- Local variables
- Iface : Node_Id;
- Iface_Def : Node_Id;
- Iface_Typ : Entity_Id;
+ Iface : Node_Id;
+ Iface_Def : Node_Id;
+ Iface_Typ : Entity_Id;
+ Parent_Node : Node_Id;
-- Start of processing for Check_Abstract_Interfaces
if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
and then Is_Interface (Etype (Defining_Identifier (N)))
then
+ Parent_Node := Parent (Etype (Defining_Identifier (N)));
+
Check_Ifaces
- (Iface_Def => Type_Definition
- (Parent (Etype (Defining_Identifier (N)))),
+ (Iface_Def => Type_Definition (Parent_Node),
Error_Node => Subtype_Indication (Type_Definition (N)));
end if;
Iface := First (Interface_List (Def));
while Present (Iface) loop
Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
- Iface_Def := Type_Definition (Parent (Iface_Typ));
+
+ Parent_Node := Parent (Base_Type (Iface_Typ));
+ Iface_Def := Type_Definition (Parent_Node);
if not Is_Interface (Iface_Typ) then
Error_Msg_NE ("(Ada 2005) & must be an interface",
-- operations used in dispatching selects since we always provide
-- automatic overridings for these subprograms.
+ -- Also ignore this rule for convention CIL since .NET libraries
+ -- do bizarre things with interfaces???
+
+ -- 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
+ -- (see exp_ch3, Build_Controlling_Function_Wrappers).
+
+ if Is_Null_Extension (T)
+ and then Has_Controlling_Result (Subp)
+ and then Ada_Version >= Ada_05
+ and then Present (Alias (Subp))
+ and then not Comes_From_Source (Subp)
+ and then not Is_Abstract_Subprogram (Alias (Subp))
+ then
+ goto Next_Subp;
+ end if;
+
if (Is_Abstract_Subprogram (Subp)
or else Requires_Overriding (Subp)
or else (Has_Controlling_Result (Subp)
and then not Is_TSS (Subp, TSS_Stream_Input)
and then not Is_TSS (Subp, TSS_Stream_Output)
and then not Is_Abstract_Type (T)
+ and then Convention (T) /= Convention_CIL
and then Chars (Subp) /= Name_uDisp_Asynchronous_Select
and then Chars (Subp) /= Name_uDisp_Conditional_Select
and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind
end if;
end if;
- Next_Elmt (Elmt);
+ <<Next_Subp>>
+ Next_Elmt (Elmt);
end loop;
end Check_Abstract_Overriding;
Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
- -- 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 that a conditional delay is set.
+ -- A subtype does not inherit the packed_array_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_Type field.
+
+ Set_Packed_Array_Type (Def_Id, Empty);
+
+ -- 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.
Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
Conditional_Delay (Def_Id, T);
-
end Constrain_Array;
------------------------------
if Ekind (Old_Compon) = E_Discriminant
and then Is_Completely_Hidden (Old_Compon)
then
-
-- This is a shadow discriminant created for a discriminant of
-- the parent type that is one of several renamed by the same
-- new discriminant. Give the shadow discriminant an internal
return Nkind (Parent (T)) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition
and then Present (Component_List (Type_Definition (Parent (T))))
- and then Present (
- Variant_Part (Component_List (Type_Definition (Parent (T)))));
+ and then
+ Present
+ (Variant_Part (Component_List (Type_Definition (Parent (T)))));
end Is_Variant_Record;
-- Start of processing for Create_Constrained_Components
Set_Has_Static_Discriminants (Subt, Is_Static);
- New_Scope (Subt);
+ Push_Scope (Subt);
-- Inherit the discriminants of the parent type
Is_Abstract_Subprogram (E));
Remove_Homonym (Iface_Subp);
+ -- Hidden entities associated with interfaces must have set the
+ -- Has_Delay_Freeze attribute to ensure that the corresponding
+ -- entry of the secondary dispatch table is filled when such
+ -- entity is frozen.
+
+ Set_Has_Delayed_Freeze (Iface_Subp);
+
Next_Elmt (Elmt);
end loop;
end if;
then
Set_Is_Abstract_Subprogram (New_Subp);
- -- Finally, if the parent type is abstract we must verify that all
+ -- Finally, if the parent type is abstract we must verify that all
-- inherited operations are either non-abstract or overridden, or
-- that the derived type itself is abstract (this check is performed
-- at the end of a package declaration, in Check_Abstract_Overriding).
and then Is_Private_Overriding
and then Is_Abstract_Subprogram (Visible_Subp)
then
- Set_Alias (New_Subp, Visible_Subp);
- Set_Is_Abstract_Subprogram (New_Subp);
+ if No (Actual_Subp) then
+ Set_Alias (New_Subp, Visible_Subp);
+ Set_Is_Abstract_Subprogram
+ (New_Subp, True);
+ else
+ -- If this is a derivation for an instance of a formal derived
+ -- type, abstractness comes from the primitive operation of the
+ -- actual, not from the operation inherited from the ancestor.
+
+ Set_Is_Abstract_Subprogram
+ (New_Subp, Is_Abstract_Subprogram (Actual_Subp));
+ end if;
end if;
New_Overloaded_Entity (New_Subp, Derived_Type);
end if;
else
+
+ -- If the generic parent type is present, the derived type
+ -- is an instance of a formal derived type, and within the
+ -- instance its operations are those of the actual. We derive
+ -- from the formal type but make the inherited operations
+ -- aliases of the corresponding operations of the actual.
+
+ if Is_Interface (Parent_Type) then
+
+ -- Find the corresponding operation in the generic actual.
+ -- Given that the actual is not a direct descendant of the
+ -- parent, as in Ada 95, the primitives are not necessarily
+ -- in the same order, so we have to traverse the list of
+ -- primitive operations of the actual to find the one that
+ -- implements the interface operation.
+
+ Act_Elmt := First_Elmt (Act_List);
+
+ while Present (Act_Elmt) loop
+ exit when
+ Abstract_Interface_Alias (Node (Act_Elmt)) = Subp;
+ Next_Elmt (Act_Elmt);
+ end loop;
+ end if;
+
+ -- If the formal is not an interface, the actual is a direct
+ -- descendant and the common primitive operations appear in
+ -- the same order.
+
Derive_Subprogram
(New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
- Next_Elmt (Act_Elmt);
+
+ if Present (Act_Elmt) then
+ Next_Elmt (Act_Elmt);
+ end if;
end if;
end if;
Next_Elmt (Elmt);
end loop;
+ -- Inherit additional operations from progenitor interfaces.
+ -- However, if the derived type is a generic actual, there
+ -- are not new primitive operations for the type, because
+ -- it has those of the actual, so nothing needs to be done.
+ -- The renamings generated above are not primitive operations,
+ -- and their purpose is simply to make the proper operations
+ -- visible within an instantiation.
+
if Ada_Version >= Ada_05
and then Is_Tagged_Type (Derived_Type)
+ and then No (Generic_Actual)
then
Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List);
end if;
N : Node_Id;
Is_Completion : Boolean)
is
- Def : constant Node_Id := Type_Definition (N);
- Iface_Def : Node_Id;
- Indic : constant Node_Id := Subtype_Indication (Def);
- Extension : constant Node_Id := Record_Extension_Part (Def);
Parent_Type : Entity_Id;
- Parent_Scope : Entity_Id;
- Taggd : Boolean;
function Comes_From_Generic (Typ : Entity_Id) return Boolean;
-- Check whether the parent type is a generic formal, or derives
end if;
end Comes_From_Generic;
+ -- Local variables
+
+ Def : constant Node_Id := Type_Definition (N);
+ Iface_Def : Node_Id;
+ Indic : constant Node_Id := Subtype_Indication (Def);
+ Extension : constant Node_Id := Record_Extension_Part (Def);
+ Parent_Node : Node_Id;
+ Parent_Scope : Entity_Id;
+ Taggd : Boolean;
+
-- Start of processing for Derived_Type_Declaration
begin
Indic, Parent_Type);
else
- Iface_Def := Type_Definition (Parent (Parent_Type));
+ Parent_Node := Parent (Base_Type (Parent_Type));
+ Iface_Def := Type_Definition (Parent_Node);
-- Ada 2005 (AI-251): Limited interfaces can only inherit from
-- other limited interfaces.
if not Is_Interface (T) then
Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T);
- elsif Limited_Present (Def)
+ -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow
+ -- a limited type from having a nonlimited progenitor.
+
+ elsif (Limited_Present (Def)
+ or else (not Is_Interface (Parent_Type)
+ and then Is_Limited_Type (Parent_Type)))
and then not Is_Limited_Interface (T)
then
Error_Msg_NE
Set_Is_Static_Expression (B_Node, True);
Set_High_Bound (R_Node, B_Node);
- Set_Scalar_Range (T, R_Node);
- Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
- Set_Enum_Esize (T);
+
+ -- Initialize various fields of the type. Some of this information
+ -- may be overwritten later through rep.clauses.
+
+ Set_Scalar_Range (T, R_Node);
+ Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
+ Set_Enum_Esize (T);
+ Set_Enum_Pos_To_Rep (T, Empty);
-- Set Discard_Names if configuration pragma set, or if there is
-- a parameterless pragma in the current declarative region
elsif Def_Kind = N_Access_Definition then
T := Access_Definition (Related_Nod, Obj_Def);
-
- if Nkind (Parent (Related_Nod)) /= N_Extended_Return_Statement then
- Set_Is_Local_Anonymous_Access (T);
- end if;
+ Set_Is_Local_Anonymous_Access (T);
-- Otherwise, the object definition is just a subtype_mark
-- type T_2 is new Pack_1.T_1 with ...;
-- end Pack_2;
- -- When Comp is being duplicated for type T_2, its designated
- -- type must be set to point to the non-limited view of T_2.
-
- if Ada_Version >= Ada_05
- and then
- Ekind (Etype (New_C)) = E_Anonymous_Access_Type
- and then
- Ekind (Directly_Designated_Type
- (Etype (New_C))) = E_Incomplete_Type
- and then
- From_With_Type (Directly_Designated_Type (Etype (New_C)))
- and then
- Present (Non_Limited_View
- (Directly_Designated_Type (Etype (New_C))))
- and then
- Non_Limited_View (Directly_Designated_Type
- (Etype (New_C))) = Derived_Base
- then
- Set_Directly_Designated_Type
- (Etype (New_C),
- Non_Limited_View
- (Directly_Designated_Type (Etype (New_C))));
-
- else
- Set_Etype
- (New_C,
- Constrain_Component_Type
- (Old_C, Derived_Base, N, Parent_Base, Discs));
- end if;
+ Set_Etype
+ (New_C,
+ Constrain_Component_Type
+ (Old_C, Derived_Base, N, Parent_Base, Discs));
end if;
end if;
-- Record_Type_Definition after processing the record extension of
-- the derived type.
- if Is_Tagged and then Ekind (New_C) = E_Component then
+ -- If the declaration is a private extension, there is no further
+ -- record extension to process, and the components retain their
+ -- current kind, because they are visible at this point.
+
+ if Is_Tagged and then Ekind (New_C) = E_Component
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ then
Set_Ekind (New_C, E_Void);
end if;
Component := First_Entity (Parent_Base);
while Present (Component) loop
- -- Ada 2005 (AI-251): Do not inherit tags corresponding with the
- -- interfaces of the parent
+ -- Ada 2005 (AI-251): Do not inherit components associated with
+ -- secondary tags of the parent.
if Ekind (Component) = E_Component
- and then Is_Tag (Component)
- and then RTE_Available (RE_Interface_Tag)
- and then Etype (Component) = RTE (RE_Interface_Tag)
+ and then Present (Related_Interface (Component))
then
null;
-----------------------
function Is_Null_Extension (T : Entity_Id) return Boolean is
- Type_Decl : constant Node_Id := Parent (T);
- Comp_List : Node_Id;
- First_Comp : Node_Id;
+ Type_Decl : constant Node_Id := Parent (T);
+ Comp_List : Node_Id;
+ Comp : Node_Id;
begin
if Nkind (Type_Decl) /= N_Full_Type_Declaration
elsif Present (Comp_List)
and then Is_Non_Empty_List (Component_Items (Comp_List))
then
- First_Comp := First (Component_Items (Comp_List));
+ Comp := First (Component_Items (Comp_List));
+
+ -- Only user-defined components are relevant. The component list
+ -- may also contain a parent component and internal components
+ -- corresponding to secondary tags, but these do not determine
+ -- whether this is a null extension.
+
+ while Present (Comp) loop
+ if Comes_From_Source (Comp) then
+ return False;
+ end if;
- return Chars (Defining_Identifier (First_Comp)) = Name_uParent
- and then No (Next (First_Comp));
+ Next (Comp);
+ end loop;
+ return True;
else
return True;
end if;
if not Is_Overloaded (I) then
T := Etype (I);
- -- If the bounds are universal, choose the specific predefined
- -- type.
+ -- For universal bounds, choose the specific predefined type
if T = Universal_Integer then
T := Standard_Integer;
elsif T = Any_Character then
-
- if Ada_Version >= Ada_95 then
- Error_Msg_N
- ("ambiguous character literals (could be Wide_Character)",
- I);
- end if;
+ Ambiguous_Character (Low_Bound (I));
T := Standard_Character;
end if;
if Bits > System_Max_Nonbinary_Modulus_Power then
Error_Msg_Uint_1 :=
UI_From_Int (System_Max_Nonbinary_Modulus_Power);
- Error_Msg_N
+ Error_Msg_F
("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr);
Set_Modular_Size (System_Max_Binary_Modulus_Power);
return;
-- so we just signal an error and set the maximum size.
Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power);
- Error_Msg_N ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
+ Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr);
Set_Modular_Size (System_Max_Binary_Modulus_Power);
Init_Alignment (T);
-
end Modular_Type_Declaration;
--------------------------
-- Ada 2005 (AI-287, AI-318): Relax the strictness of the front-end in
-- case of limited aggregates (including extension aggregates),
- -- and function calls.
+ -- and function calls. The function call may have been give in prefixed
+ -- notation, in which case the original node is an indexed component.
case Nkind (Original_Node (Exp)) is
- when N_Aggregate | N_Extension_Aggregate | N_Function_Call =>
+ when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
return True;
- when N_Qualified_Expression =>
+ -- Ada 2005 (AI-251): If a class-wide interface object is initialized
+ -- with a function call, the expander has rewriten the call into an
+ -- N_Type_Conversion node to force displacement of the pointer to
+ -- reference the component containing the secondary dispatch table.
+
+ when N_Qualified_Expression | N_Type_Conversion =>
return OK_For_Limited_Init_In_05
(Expression (Original_Node (Exp)));
+ when N_Indexed_Component =>
+ return Nkind (Exp) = N_Function_Call;
+
when others =>
return False;
end case;
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
- -- Ada 2005 (AI-230): Access discriminants are now allowed for
- -- nonlimited types, and are treated like other components of
- -- anonymous access types in terms of accessibility.
-
- if not Is_Concurrent_Type (Current_Scope)
- and then not Is_Concurrent_Record_Type (Current_Scope)
- and then not Is_Limited_Record (Current_Scope)
- and then Ekind (Current_Scope) /= E_Limited_Private_Type
- then
- Set_Is_Local_Anonymous_Access (Discr_Type);
- end if;
-
-- Ada 2005 (AI-254)
if Present (Access_To_Subprogram_Definition
and then not Is_Itype (Discr_Type)
then
if Can_Never_Be_Null (Discr_Type) then
- Error_Msg_N
- ("null-exclusion cannot be applied to " &
- "a null excluding type", Discr);
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ Discr,
+ Discr_Type);
end if;
Set_Etype (Defining_Identifier (Discr),
end loop;
end;
- -- If the private view was tagged, copy the new Primitive
- -- operations from the private view to the full view.
+ -- If the private view was tagged, copy the new primitive operations
+ -- from the private view to the full view.
if Is_Tagged_Type (Full_T)
and then not Is_Concurrent_Type (Full_T)
Set_Must_Have_Preelab_Init (Full_T);
end if;
end if;
+
+ -- If pragma CPP_Class was applied to the private type declaration,
+ -- propagate it now to the full type declaration.
+
+ if Is_CPP_Class (Priv_T) then
+ Set_Is_CPP_Class (Full_T);
+ Set_Convention (Full_T, Convention_CPP);
+ end if;
end Process_Full_View;
-----------------------------------
and then Nkind (P) /= N_Access_To_Object_Definition
and then not Is_Access_Type (Entity (S))
then
- Error_Msg_N
- ("null-exclusion must be applied to an access type", S);
+ Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
end if;
May_Have_Null_Exclusion :=
Error_Node := Related_Nod;
end case;
- Error_Msg_N
- ("null-exclusion cannot be applied to " &
- "a null excluding type", Error_Node);
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ Error_Node,
+ Entity (S));
end if;
Set_Etype (S,
Subt : Node_Id;
Type_Id : constant Name_Id := Chars (Typ);
+ 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.
+
+ function Names_T (Nam : Node_Id) return Boolean is
+ begin
+ if Nkind (Nam) = N_Identifier then
+ return Chars (Nam) = Type_Id;
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ if Chars (Selector_Name (Nam)) = Type_Id then
+ if Nkind (Prefix (Nam)) = N_Identifier then
+ return Chars (Prefix (Nam)) = Chars (Current_Scope);
+
+ elsif Nkind (Prefix (Nam)) = N_Selected_Component then
+ return Chars (Selector_Name (Prefix (Nam)))
+ = Chars (Current_Scope);
+ else
+ return False;
+ end if;
+ else
+ return False;
+ end if;
+ else
+ return False;
+ end if;
+ end Names_T;
+
begin
if No (Access_To_Subprogram_Definition (Acc_Def)) then
Subt := Subtype_Mark (Acc_Def);
return Chars (Subt) = Type_Id;
-- Reference can be through an expanded name which has not been
- -- analyzed yet, and designates enclosing scopes.
+ -- analyzed yet, and which designates enclosing scopes.
elsif Nkind (Subt) = N_Selected_Component then
- Analyze (Prefix (Subt));
-
- if Chars (Selector_Name (Subt)) = Type_Id then
- return Is_Entity_Name (Prefix (Subt))
- and then Entity (Prefix (Subt)) = Current_Scope;
+ if Names_T (Subt) then
+ return True;
+ -- 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.
-- a 'Class attribute.
elsif Nkind (Subt) = N_Attribute_Reference
- and then Attribute_Name (Subt) = Name_Class
- and then Is_Entity_Name (Prefix (Subt))
+ and then Attribute_Name (Subt) = Name_Class
then
- return (Chars (Prefix (Subt))) = Type_Id;
+ return Names_T (Prefix (Subt));
else
return False;
end if;
Relocate_Node
(Subtype_Mark
(Access_Definition (Comp_Def))));
+
+ Set_Constant_Present
+ (Type_Def, Constant_Present (Access_Definition (Comp_Def)));
+ Set_All_Present
+ (Type_Def, All_Present (Access_Definition (Comp_Def)));
end if;
- Decl := Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Anon_Access,
- Type_Definition => Type_Def);
+ Set_Null_Exclusion_Present
+ (Type_Def,
+ Null_Exclusion_Present (Access_Definition (Comp_Def)));
+
+ Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Anon_Access,
+ Type_Definition => Type_Def);
Insert_Before (Typ_Decl, Decl);
Analyze (Decl);
-- Enter record scope
- New_Scope (T);
+ Push_Scope (T);
-- If an incomplete or private type declaration was already given for
-- the type, then this scope already exists, and the discriminants have
-- After completing the semantic analysis of the record definition,
-- record components, both new and inherited, are accessible. Set their
- -- kind accordingly.
+ -- kind accordingly. Exclude malformed itypes from illegal declarations,
+ -- whose Ekind may be void.
Component := First_Entity (Current_Scope);
while Present (Component) loop
- if Ekind (Component) = E_Void then
+ if Ekind (Component) = E_Void
+ and then not Is_Itype (Component)
+ then
Set_Ekind (Component, E_Component);
Init_Component_Location (Component);
end if;
projects / gcc.git / commitdiff