-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
Subtype_Indication => Subtype_Mark (Def));
Set_Abstract_Present (New_N, Abstract_Present (Def));
+ Set_Limited_Present (New_N, Limited_Present (Def));
else
New_N :=
Set_Abstract_Present
(Type_Definition (New_N), Abstract_Present (Def));
+ Set_Limited_Present
+ (Type_Definition (New_N), Limited_Present (Def));
end if;
Rewrite (N, New_N);
Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
begin
- if not Present (Ctrl_Type) then
+ if No (Ctrl_Type) then
Error_Msg_N
("abstract formal subprogram must have a controlling type",
N);
Cunit_Entity (Current_Sem_Unit);
Removed : Boolean := False;
Num_Scopes : Int := 0;
- Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
- Instances : array (1 .. Scope_Stack.Last) of Entity_Id;
- Inner_Scopes : array (1 .. Scope_Stack.Last) of Entity_Id;
+
+ Scope_Stack_Depth : constant Int :=
+ Scope_Stack.Last - Scope_Stack.First + 1;
+
+ Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
+ Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
+ Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
Num_Inner : Int := 0;
N_Instances : Int := 0;
S : Entity_Id;
-- because each actual has the same name as the formal, and they do
-- appear in the same order.
- function Formal_Entity
- (F : Node_Id;
- Act_Ent : Entity_Id) return Entity_Id;
- -- Returns the entity associated with the given formal F. In the
- -- case where F is a formal package, this function will iterate
- -- through all of F's formals and enter map associations from the
+ function Get_Formal_Entity (N : Node_Id) return Entity_Id;
+ -- Retrieve entity of defining entity of generic formal parameter.
+ -- Only the declarations of formals need to be considered when
+ -- linking them to actuals, but the declarative list may include
+ -- internal entities generated during analysis, and those are ignored.
+
+ procedure Match_Formal_Entity
+ (Formal_Node : Node_Id;
+ Formal_Ent : Entity_Id;
+ Actual_Ent : Entity_Id);
+ -- Associates the formal entity with the actual. In the case
+ -- where Formal_Ent is a formal package, this procedure iterates
+ -- through all of its formals and enters associations betwen the
-- actuals occurring in the formal package's corresponding actual
- -- package (obtained via Act_Ent) to the formal package's formal
- -- parameters. This function is called recursively for arbitrary
- -- levels of formal packages.
+ -- package (given by Actual_Ent) and the formal package's formal
+ -- parameters. This procedure recurses if any of the parameters is
+ -- itself a package.
function Is_Instance_Of
(Act_Spec : Entity_Id;
end case;
end Find_Matching_Actual;
- -------------------
- -- Formal_Entity --
- -------------------
+ -------------------------
+ -- Match_Formal_Entity --
+ -------------------------
- function Formal_Entity
- (F : Node_Id;
- Act_Ent : Entity_Id) return Entity_Id
+ procedure Match_Formal_Entity
+ (Formal_Node : Node_Id;
+ Formal_Ent : Entity_Id;
+ Actual_Ent : Entity_Id)
is
- Orig_Node : Node_Id := F;
Act_Pkg : Entity_Id;
begin
- case Nkind (Original_Node (F)) is
- when N_Formal_Object_Declaration =>
- return Defining_Identifier (F);
+ Set_Instance_Of (Formal_Ent, Actual_Ent);
- when N_Formal_Type_Declaration =>
- return Defining_Identifier (F);
+ if Ekind (Actual_Ent) = E_Package then
+ -- Record associations for each parameter
- when N_Formal_Subprogram_Declaration =>
- return Defining_Unit_Name (Specification (F));
+ Act_Pkg := Actual_Ent;
- when N_Package_Declaration =>
- return Defining_Unit_Name (Specification (F));
+ declare
+ A_Ent : Entity_Id := First_Entity (Act_Pkg);
+ F_Ent : Entity_Id;
+ F_Node : Node_Id;
- when N_Formal_Package_Declaration |
- N_Generic_Package_Declaration =>
+ Gen_Decl : Node_Id;
+ Formals : List_Id;
+ Actual : Entity_Id;
- if Nkind (F) = N_Generic_Package_Declaration then
- Orig_Node := Original_Node (F);
- end if;
+ begin
+ -- Retrieve the actual given in the formal package declaration
- Act_Pkg := Act_Ent;
+ Actual := Entity (Name (Original_Node (Formal_Node)));
- -- Find matching actual package, skipping over itypes and
- -- other entities generated when analyzing the formal. We
- -- know that if the instantiation is legal then there is
- -- a matching package for the formal.
+ -- The actual in the formal package declaration may be a
+ -- renamed generic package, in which case we want to retrieve
+ -- the original generic in order to traverse its formal part.
- while Ekind (Act_Pkg) /= E_Package loop
- Act_Pkg := Next_Entity (Act_Pkg);
- end loop;
+ if Present (Renamed_Entity (Actual)) then
+ Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual));
+ else
+ Gen_Decl := Unit_Declaration_Node (Actual);
+ end if;
- declare
- Actual_Ent : Entity_Id := First_Entity (Act_Pkg);
- Formal_Node : Node_Id;
- Formal_Ent : Entity_Id;
+ Formals := Generic_Formal_Declarations (Gen_Decl);
- Gen_Decl : Node_Id;
- Formals : List_Id;
+ if Present (Formals) then
+ F_Node := First_Non_Pragma (Formals);
+ else
+ F_Node := Empty;
+ end if;
- begin
- -- The actual may be a renamed generic package, in which
- -- case we want to retrieve the original generic in order
- -- to traverse its formal part.
-
- if Present (Renamed_Entity (Entity (Name (Orig_Node)))) then
- Gen_Decl :=
- Unit_Declaration_Node (
- Renamed_Entity (Entity (Name (Orig_Node))));
- else
- Gen_Decl :=
- Unit_Declaration_Node (Entity (Name (Orig_Node)));
- end if;
+ while Present (A_Ent)
+ and then Present (F_Node)
+ and then A_Ent /= First_Private_Entity (Act_Pkg)
+ loop
+ F_Ent := Get_Formal_Entity (F_Node);
- Formals := Generic_Formal_Declarations (Gen_Decl);
+ if Present (F_Ent) then
- if Present (Formals) then
- Formal_Node := First_Non_Pragma (Formals);
- else
- Formal_Node := Empty;
+ -- This is a formal of the original package. Record
+ -- association and recurse.
+
+ Find_Matching_Actual (F_Node, A_Ent);
+ Match_Formal_Entity (F_Node, F_Ent, A_Ent);
+ Next_Entity (A_Ent);
end if;
- while Present (Actual_Ent)
- and then Present (Formal_Node)
- and then Actual_Ent /= First_Private_Entity (Act_Pkg)
- loop
- -- ??? Are the following calls also needed here:
- --
- -- Set_Is_Hidden (Actual_Ent, False);
- -- Set_Is_Potentially_Use_Visible
- -- (Actual_Ent, In_Use (Act_Ent));
+ Next_Non_Pragma (F_Node);
+ end loop;
+ end;
+ end if;
+ end Match_Formal_Entity;
- Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
- if Present (Formal_Ent) then
- Set_Instance_Of (Formal_Ent, Actual_Ent);
- end if;
- Next_Non_Pragma (Formal_Node);
+ -----------------------
+ -- Get_Formal_Entity --
+ -----------------------
- Next_Entity (Actual_Ent);
- end loop;
- end;
+ function Get_Formal_Entity (N : Node_Id) return Entity_Id is
+ Kind : constant Node_Kind := Nkind (Original_Node (N));
+ begin
+ case Kind is
+ when N_Formal_Object_Declaration =>
+ return Defining_Identifier (N);
+
+ when N_Formal_Type_Declaration =>
+ return Defining_Identifier (N);
- return Defining_Identifier (Orig_Node);
+ when N_Formal_Subprogram_Declaration =>
+ return Defining_Unit_Name (Specification (N));
- when N_Use_Package_Clause =>
- return Empty;
+ when N_Formal_Package_Declaration =>
+ return Defining_Identifier (Original_Node (N));
- when N_Use_Type_Clause =>
- return Empty;
+ when N_Generic_Package_Declaration =>
+ return Defining_Identifier (Original_Node (N));
- -- We return Empty for all other encountered forms of
- -- declarations because there are some cases of nonformal
- -- sorts of declaration that can show up (e.g., when array
- -- formals are present). Since it's not clear what kinds
- -- can appear among the formals, we won't raise failure here.
+ -- All other declarations are introduced by semantic analysis
+ -- and have no match in the actual.
- when others =>
+ when others =>
return Empty;
-
end case;
- end Formal_Entity;
+ end Get_Formal_Entity;
--------------------
-- Is_Instance_Of --
end if;
if Present (Formal_Node) then
- Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
+ Formal_Ent := Get_Formal_Entity (Formal_Node);
if Present (Formal_Ent) then
Find_Matching_Actual (Formal_Node, Actual_Ent);
- Set_Instance_Of (Formal_Ent, Actual_Ent);
+ Match_Formal_Entity
+ (Formal_Node, Formal_Ent, Actual_Ent);
end if;
Next_Non_Pragma (Formal_Node);
and then Present (Ancestor_Discr)
loop
if Base_Type (Act_T) /= Base_Type (Ancestor) and then
- not Present (Corresponding_Discriminant (Actual_Discr))
+ No (Corresponding_Discriminant (Actual_Discr))
then
Error_Msg_NE
("discriminant & does not correspond " &
(Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
Renamings_Included => True) then
Ada_Version := Ada_Version_Type'Last;
- Ada_Version_Explicit := Ada_Version_Explicit_Config;
end if;
Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
(Def_Id : Entity_Id;
R : Node_Id;
Subt : Entity_Id);
- -- This routine is used to set the scalar range field for a subtype
- -- given Def_Id, the entity for the subtype, and R, the range expression
- -- for the scalar range. Subt provides the parent subtype to be used
- -- to analyze, resolve, and check the given range.
+ -- This routine is used to set the scalar range field for a subtype given
+ -- Def_Id, the entity for the subtype, and R, the range expression for the
+ -- scalar range. Subt provides the parent subtype to be used to analyze,
+ -- resolve, and check the given range.
procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
-- Create a new signed integer entity, and apply the constraint to obtain
(Related_Nod : Node_Id;
N : Node_Id) return Entity_Id
is
- Anon_Type : constant Entity_Id :=
- Create_Itype (E_Anonymous_Access_Type, Related_Nod,
- Scope_Id => Scope (Current_Scope));
+ Anon_Type : Entity_Id;
Desig_Type : Entity_Id;
begin
Error_Msg_N ("task entries cannot have access parameters", N);
end if;
- -- Ada 2005: for an object declaration or function with an anonymous
- -- access result, the corresponding anonymous type is declared in the
- -- current scope. For access formals, access components, and access
- -- discriminants, the scope is that of the enclosing declaration,
- -- as set above. This special-case handling of resetting the scope
- -- is awkward, and it might be better to pass in the required scope
- -- as a parameter. ???
+ -- Ada 2005: for an object declaration the corresponding anonymous
+ -- type is declared in the current scope.
if Nkind (Related_Nod) = N_Object_Declaration then
- Set_Scope (Anon_Type, Current_Scope);
+ Anon_Type :=
+ Create_Itype
+ (E_Anonymous_Access_Type, Related_Nod,
+ Scope_Id => Current_Scope);
-- For the anonymous function result case, retrieve the scope of
-- the function specification's associated entity rather than using
elsif Nkind (Related_Nod) = N_Function_Specification
and then Nkind (Parent (N)) /= N_Parameter_Specification
then
- Set_Scope (Anon_Type, Scope (Defining_Unit_Name (Related_Nod)));
+ Anon_Type :=
+ Create_Itype
+ (E_Anonymous_Access_Type, Related_Nod,
+ Scope_Id => Scope (Defining_Unit_Name (Related_Nod)));
+
+ 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));
end if;
if All_Present (N)
-------------
procedure Add_Tag (Iface : Entity_Id) is
- Def : Node_Id;
- Tag : Entity_Id;
- Decl : Node_Id;
+ Decl : Node_Id;
+ Def : Node_Id;
+ Tag : Entity_Id;
+ Offset : Entity_Id;
begin
pragma Assert (Is_Tagged_Type (Iface)
Set_DT_Entry_Count (Tag,
DT_Entry_Count (First_Entity (Iface)));
- if not Present (Last_Tag) then
+ if No (Last_Tag) then
Prepend (Decl, L);
else
Insert_After (Last_Tag, Decl);
end if;
Last_Tag := Decl;
+
+ -- If the ancestor has discriminants we need to give special support
+ -- to store the offset_to_top value of the secondary dispatch tables.
+ -- For this purpose we add a supplementary component just after the
+ -- field that contains the tag associated with each secondary DT.
+
+ if Typ /= Etype (Typ)
+ and then Has_Discriminants (Etype (Typ))
+ then
+ Def :=
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
+
+ Offset :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
+
+ Decl :=
+ Make_Component_Declaration (Loc,
+ Defining_Identifier => Offset,
+ Component_Definition => Def);
+
+ Analyze_Component_Declaration (Decl);
+
+ Set_Analyzed (Decl);
+ Set_Ekind (Offset, E_Component);
+ Init_Component_Location (Offset);
+ Insert_After (Last_Tag, Decl);
+ Last_Tag := Decl;
+ end if;
end Add_Tag;
-- Start of processing for Add_Interface_Tag_Components
begin
if Ekind (Typ) /= E_Record_Type
- or else not Present (Abstract_Interfaces (Typ))
+ or else No (Abstract_Interfaces (Typ))
or else Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ or else not RTE_Available (RE_Interface_Tag)
then
return;
end if;
-- Determines whether a constraint uses the discriminant of a record
-- type thus becoming a per-object constraint (POC).
+ function Is_Known_Limited (Typ : Entity_Id) return Boolean;
+ -- Check whether enclosing record is limited, to validate declaration
+ -- of components with limited types.
+ -- This seems a wrong description to me???
+ -- What is Typ? For sure it can return a result without checking
+ -- the enclosing record (enclosing what???)
+
------------------
-- Contains_POC --
------------------
end case;
end Contains_POC;
+ ----------------------
+ -- Is_Known_Limited --
+ ----------------------
+
+ function Is_Known_Limited (Typ : Entity_Id) return Boolean is
+ P : constant Entity_Id := Etype (Typ);
+ R : constant Entity_Id := Root_Type (Typ);
+
+ begin
+ if Is_Limited_Record (Typ) then
+ return True;
+
+ -- If the root type is limited (and not a limited interface)
+ -- so is the current type
+
+ elsif Is_Limited_Record (R)
+ and then
+ (not Is_Interface (R)
+ or else not Is_Limited_Interface (R))
+ then
+ return True;
+
+ -- Else the type may have a limited interface progenitor, but a
+ -- limited record parent.
+
+ elsif R /= P
+ and then Is_Limited_Record (P)
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Known_Limited;
+
-- Start of processing for Analyze_Component_Declaration
begin
if Present (Expression (N)) then
Analyze_Per_Use_Expression (Expression (N), T);
Check_Initialization (T, Expression (N));
+
+ 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
+ -- an anonymous access-to-specific tagged type, then the object
+ -- designated by the expression shall not be dynamically tagged
+ -- unless it is a controlling operand in a call on a dispatching
+ -- operation"
+
+ if Is_Tagged_Type (Directly_Designated_Type (T))
+ and then
+ Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type
+ and then
+ Ekind (Directly_Designated_Type (Etype (Expression (N)))) =
+ E_Class_Wide_Type
+ then
+ Error_Msg_N
+ ("access to specific tagged type required ('R'M 3.9.2(9))",
+ Expression (N));
+ end if;
+
+ -- (Ada 2005: AI-230): Accessibility check for anonymous
+ -- components
+
+ if Type_Access_Level (Etype (Expression (N))) >
+ Type_Access_Level (T)
+ then
+ Error_Msg_N
+ ("expression has deeper access level than component " &
+ "('R'M 3.10.2 (12.2))", Expression (N));
+ end if;
+ end if;
end if;
-- The parent type may be a private view with unknown discriminants,
and then Is_Tagged_Type (Current_Scope)
then
if Is_Derived_Type (Current_Scope)
- and then not Is_Limited_Record (Root_Type (Current_Scope))
+ and then not Is_Known_Limited (Current_Scope)
then
Error_Msg_N
("extension of nonlimited type cannot have limited components",
N);
+
+ if Is_Interface (Root_Type (Current_Scope)) then
+ Error_Msg_N
+ ("\limitedness is not inherited from limited interface", N);
+ Error_Msg_N
+ ("\add LIMITED to type indication", N);
+ end if;
+
Explain_Limited_Type (T, N);
Set_Etype (Id, Any_Type);
Set_Is_Limited_Composite (Current_Scope, False);
-- In case of errors detected in the analysis of the expression,
-- decorate it with the expected type to avoid cascade errors
- if not Present (Etype (E)) then
+ if No (Etype (E)) then
Set_Etype (E, T);
end if;
if Limited_Present (N) then
Set_Is_Limited_Record (T);
- if not Is_Limited_Type (Parent_Type) then
+ if not Is_Limited_Type (Parent_Type)
+ and then
+ (not Is_Interface (Parent_Type)
+ or else not Is_Limited_Interface (Parent_Type))
+ then
Error_Msg_NE ("parent type& of limited extension must be limited",
N, Parent_Type);
end if;
Constraint_Present : Boolean;
Has_Interfaces : Boolean := False;
Inherit_Discrims : Boolean := False;
- Last_Inherited_Prim_Op : Elmt_Id;
Tagged_Partial_View : Entity_Id;
Save_Etype : Entity_Id;
Save_Discr_Constr : Elist_Id;
Discrim := First_Discriminant (Derived_Type);
while Present (Discrim) loop
if not Is_Tagged
- and then not Present (Corresponding_Discriminant (Discrim))
+ and then No (Corresponding_Discriminant (Discrim))
then
Error_Msg_N
("new discriminants must constrain old ones", Discrim);
else
Collect_Interfaces (Type_Definition (N), Derived_Type);
end if;
-
- -- Ada 2005 (AI-251): The progenitor types specified in a private
- -- extension declaration and the progenitor types specified in the
- -- corresponding declaration of a record extension given in the
- -- private part need not be the same; the only requirement is that
- -- the private extension must be descended from each interface
- -- from which the record extension is descended (AARM 7.3, 20.1/2)
-
- if Has_Private_Declaration (Derived_Type) then
- declare
- N_Partial : constant Node_Id := Parent (Tagged_Partial_View);
- Iface_Partial : Entity_Id;
-
- begin
- if Nkind (N_Partial) = N_Private_Extension_Declaration
- and then not Is_Empty_List (Interface_List (N_Partial))
- then
- Iface_Partial := First (Interface_List (N_Partial));
-
- while Present (Iface_Partial) loop
- if not Interface_Present_In_Ancestor
- (Derived_Type, Etype (Iface_Partial))
- then
- Error_Msg_N
- ("(Ada 2005) full type and private extension must"
- & " have the same progenitors", Derived_Type);
- exit;
- end if;
-
- Next (Iface_Partial);
- end loop;
- end if;
- end;
- end if;
end if;
else
Constrs := Discriminant_Constraint (Parent_Type);
end if;
- Assoc_List := Inherit_Components (N,
- Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
+ Assoc_List :=
+ Inherit_Components
+ (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
-- STEP 5a: Copy the parent record declaration for untagged types
end;
end if;
- -- Ada 2005 (AI-251): Keep separate the management of tagged types
- -- implementing interfaces
+ Derive_Subprograms (Parent_Type, Derived_Type);
+
+ -- Ada 2005 (AI-251): Handle tagged types implementing interfaces
- if not Is_Tagged_Type (Derived_Type)
- or else not Has_Interfaces
+ if Is_Tagged_Type (Derived_Type)
+ and then Has_Interfaces
then
- Derive_Subprograms (Parent_Type, Derived_Type);
+ -- Ada 2005 (AI-251): If we are analyzing a full view that has
+ -- no partial view we derive the abstract interface Subprograms
- else
- -- Ada 2005 (AI-251): Complete the decoration of tagged private
- -- types that implement interfaces
+ if No (Tagged_Partial_View) then
+ Derive_Interface_Subprograms (Derived_Type);
- if Present (Tagged_Partial_View) then
- Derive_Subprograms
- (Parent_Type, Derived_Type);
+ -- Ada 2005 (AI-251): if we are analyzing a full view that has
+ -- a partial view we complete the derivation of the subprograms
+ else
Complete_Subprograms_Derivation
(Partial_View => Tagged_Partial_View,
Derived_Type => Derived_Type);
+ end if;
- -- Ada 2005 (AI-251): Derive the interface subprograms of all the
- -- implemented interfaces and check if some of the subprograms
- -- inherited from the ancestor cover some interface subprogram.
+ -- Ada 2005 (AI-251): In both cases we check if some of the
+ -- inherited subprograms cover interface primitives.
- else
- Derive_Subprograms (Parent_Type, Derived_Type);
+ declare
+ Iface_Subp : Entity_Id;
+ Iface_Subp_Elmt : Elmt_Id;
+ Prev_Alias : Entity_Id;
+ Subp : Entity_Id;
+ Subp_Elmt : Elmt_Id;
- declare
- Subp_Elmt : Elmt_Id;
- First_Iface_Elmt : Elmt_Id;
- Iface_Subp_Elmt : Elmt_Id;
- Subp : Entity_Id;
- Iface_Subp : Entity_Id;
- Is_Interface_Subp : Boolean;
+ begin
+ Iface_Subp_Elmt :=
+ First_Elmt (Primitive_Operations (Derived_Type));
+ while Present (Iface_Subp_Elmt) loop
+ Iface_Subp := Node (Iface_Subp_Elmt);
+
+ -- Look for an abstract interface subprogram
+
+ if Is_Abstract (Iface_Subp)
+ and then Present (Alias (Iface_Subp))
+ and then Present (DTC_Entity (Alias (Iface_Subp)))
+ and then Is_Interface
+ (Scope (DTC_Entity (Alias (Iface_Subp))))
+ then
+ -- Look for candidate primitive subprograms of the tagged
+ -- type that can cover this interface subprogram.
- begin
- -- Ada 2005 (AI-251): Remember the entity corresponding to
- -- the last inherited primitive operation. This is required
- -- to check if some of the inherited subprograms covers some
- -- of the new interfaces.
-
- Last_Inherited_Prim_Op := No_Elmt;
-
- Subp_Elmt :=
- First_Elmt (Primitive_Operations (Derived_Type));
- while Present (Subp_Elmt) loop
- Last_Inherited_Prim_Op := Subp_Elmt;
- Next_Elmt (Subp_Elmt);
- end loop;
+ Subp_Elmt :=
+ First_Elmt (Primitive_Operations (Derived_Type));
+ while Present (Subp_Elmt) loop
+ Subp := Node (Subp_Elmt);
- -- Ada 2005 (AI-251): Derive subprograms in abstract
- -- interfaces.
+ if not Is_Abstract (Subp)
+ and then Chars (Subp) = Chars (Iface_Subp)
+ and then Type_Conformant (Iface_Subp, Subp)
+ then
+ Prev_Alias := Alias (Iface_Subp);
- Derive_Interface_Subprograms (Derived_Type);
-
- -- Ada 2005 (AI-251): Check if some of the inherited
- -- subprograms cover some of the new interfaces.
-
- if Present (Last_Inherited_Prim_Op) then
- First_Iface_Elmt := Next_Elmt (Last_Inherited_Prim_Op);
- Iface_Subp_Elmt := First_Iface_Elmt;
- while Present (Iface_Subp_Elmt) loop
- Subp_Elmt := First_Elmt (Primitive_Operations
- (Derived_Type));
- while Subp_Elmt /= First_Iface_Elmt loop
- Subp := Node (Subp_Elmt);
- Iface_Subp := Node (Iface_Subp_Elmt);
-
- Is_Interface_Subp :=
- Present (Alias (Subp))
- and then Present (DTC_Entity (Alias (Subp)))
- and then Is_Interface (Scope
- (DTC_Entity
- (Alias (Subp))));
-
- if Chars (Subp) = Chars (Iface_Subp)
- and then not Is_Interface_Subp
- and then not Is_Abstract (Subp)
- and then Type_Conformant (Iface_Subp, Subp)
- then
- Check_Dispatching_Operation
- (Subp => Subp,
- Old_Subp => Iface_Subp);
-
- -- Traverse the list of aliased subprograms
-
- declare
- E : Entity_Id;
-
- begin
- E := Alias (Subp);
- while Present (Alias (E)) loop
- E := Alias (E);
- end loop;
-
- Set_Alias (Subp, E);
- end;
-
- Set_Has_Delayed_Freeze (Subp);
- exit;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
+ Check_Dispatching_Operation
+ (Subp => Subp,
+ Old_Subp => Iface_Subp);
+
+ pragma Assert
+ (Alias (Iface_Subp) = Subp);
+ pragma Assert
+ (Abstract_Interface_Alias (Iface_Subp)
+ = Prev_Alias);
+
+ -- Traverse the list of aliased subprograms to link
+ -- subp with its ultimate aliased subprogram. This
+ -- avoids problems with the backend.
+
+ declare
+ E : Entity_Id;
+
+ begin
+ E := Alias (Subp);
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+
+ Set_Alias (Subp, E);
+ end;
- Next_Elmt (Iface_Subp_Elmt);
+ Set_Has_Delayed_Freeze (Subp);
+ exit;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
end loop;
end if;
- end;
- end if;
+
+ Next_Elmt (Iface_Subp_Elmt);
+ end loop;
+ end;
end if;
end if;
-------------------------------
procedure Check_Abstract_Overriding (T : Entity_Id) is
- Op_List : Elist_Id;
- Elmt : Elmt_Id;
- Subp : Entity_Id;
- Type_Def : Node_Id;
+ Op_List : Elist_Id;
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ Alias_Subp : Entity_Id;
+ Type_Def : Node_Id;
begin
Op_List := Primitive_Operations (T);
Elmt := First_Elmt (Op_List);
while Present (Elmt) loop
Subp := Node (Elmt);
+ Alias_Subp := Alias (Subp);
+
+ -- Inherited subprograms are identified by the fact that they do not
+ -- come from source, and the associated source location is the
+ -- location of the first subtype of the derived type.
-- Special exception, do not complain about failure to override the
-- stream routines _Input and _Output, as well as the primitive
-- operations used in dispatching selects since we always provide
-- automatic overridings for these subprograms.
- if Is_Abstract (Subp)
+ if (Is_Abstract (Subp)
+ or else (Has_Controlling_Result (Subp)
+ and then Present (Alias_Subp)
+ and then not Comes_From_Source (Subp)
+ and then Sloc (Subp) = Sloc (First_Subtype (T))))
and then not Is_TSS (Subp, TSS_Stream_Input)
and then not Is_TSS (Subp, TSS_Stream_Output)
and then not Is_Abstract (T)
and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind
and then Chars (Subp) /= Name_uDisp_Timed_Select
then
- if Present (Alias (Subp)) then
-
- -- Only perform the check for a derived subprogram when
- -- the type has an explicit record extension. This avoids
- -- incorrectly flagging abstract subprograms for the case
- -- of a type without an extension derived from a formal type
- -- with a tagged actual (can occur within a private part).
+ if Present (Alias_Subp) then
+
+ -- Only perform the check for a derived subprogram when the
+ -- type has an explicit record extension. This avoids
+ -- incorrectly flagging abstract subprograms for the case of a
+ -- type without an extension derived from a formal type with a
+ -- tagged actual (can occur within a private part).
+
+ -- Ada 2005 (AI-391): In the case of an inherited function with
+ -- a controlling result of the type, the rule does not apply if
+ -- the type is a null extension (unless the parent function
+ -- itself is abstract, in which case the function must still be
+ -- be overridden). The expander will generate an overriding
+ -- wrapper function calling the parent subprogram (see
+ -- Exp_Ch3.Make_Controlling_Wrapper_Functions).
Type_Def := Type_Definition (Parent (T));
if Nkind (Type_Def) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Type_Def))
+ and then
+ (Ada_Version < Ada_05
+ or else not Is_Null_Extension (T)
+ or else Ekind (Subp) = E_Procedure
+ or else not Has_Controlling_Result (Subp)
+ or else Is_Abstract (Alias_Subp)
+ or else Is_Access_Type (Etype (Subp)))
then
Error_Msg_NE
("type must be declared abstract or & overridden",
T, Subp);
-- Traverse the whole chain of aliased subprograms to
- -- complete the error notification. This is useful for
- -- traceability of the chain of entities when the subprogram
- -- corresponds with interface subprogram (that may be
- -- defined in another package)
+ -- complete the error notification. This is especially
+ -- useful for traceability of the chain of entities when the
+ -- subprogram corresponds with an interface subprogram
+ -- (which might be defined in another package)
- if Ada_Version >= Ada_05
- and then Present (Alias (Subp))
- then
+ if Present (Alias_Subp) then
declare
E : Entity_Id;
Next_Elmt (Elmt);
end loop;
- if not Present (Elmt) then
+ if No (Elmt) then
Append_Elmt (Node => Iface,
To => Abstract_Interfaces (Derived_Type));
end if;
Obj_Def : constant Node_Id := Object_Definition (N);
New_T : Entity_Id;
+ 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,
-- detected when generating init procs, but requires this additional
-- mechanism when expansion is disabled.
+ ----------------------------------------
+ -- Check_Possible_Deferred_Completion --
+ ----------------------------------------
+
+ 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_Defining_Identifier (Loc,
+ New_Internal_Name ('S'));
+ Decl : constant Node_Id :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier =>
+ Def_Id,
+ Subtype_Indication =>
+ Relocate_Node (Curr_Obj_Def));
+
+ begin
+ Insert_Before_And_Analyze (N, Decl);
+ Set_Etype (Id, Def_Id);
+
+ 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;
+
---------------------------------
-- Check_Recursive_Declaration --
---------------------------------
-- If so, process the full constant declaration
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.
+
+ Check_Possible_Deferred_Completion
+ (Prev_Id => Prev,
+ Prev_Obj_Def => Object_Definition (Parent (Prev)),
+ Curr_Obj_Def => Obj_Def);
+
Set_Full_View (Prev, Id);
Set_Is_Public (Id, Is_Public (Prev));
Set_Is_Internal (Id);
(New_Subp, Is_Valued_Procedure (Parent_Subp));
end if;
+ -- No_Return must be inherited properly. If this is overridden in the
+ -- case of a dispatching operation, then a check is made in Sem_Disp
+ -- that the overriding operation is also No_Return (no such check is
+ -- required for the case of non-dispatching operation.
+
+ Set_No_Return (New_Subp, No_Return (Parent_Subp));
+
-- A derived function with a controlling result is abstract. If the
-- Derived_Type is a nonabstract formal generic derived type, then
-- inherited operations are not abstract: the required check is done at
Partial_View := First_Entity (Current_Scope);
loop
- exit when not Present (Partial_View)
+ exit when No (Partial_View)
or else (Has_Private_Declaration (Partial_View)
and then Full_View (Partial_View) = T);
Build_Derived_Type (N, Parent_Type, T, Is_Completion);
-- AI-419: the parent type of an explicitly limited derived type must
- -- be limited. Interface progenitors were checked earlier.
+ -- be a limited type or a limited interface.
if Limited_Present (Def) then
Set_Is_Limited_Record (T);
if not Is_Limited_Type (Parent_Type)
- and then not Is_Interface (Parent_Type)
+ and then
+ (not Is_Interface (Parent_Type)
+ or else not Is_Limited_Interface (Parent_Type))
then
Error_Msg_NE ("parent type& of limited type must be limited",
N, Parent_Type);
then
Error_Msg_N
("completion of nonlimited type cannot be limited", N);
+
+ elsif Ekind (Prev) = E_Record_Type_With_Private
+ and then
+ (Nkind (N) = N_Task_Type_Declaration
+ or else Nkind (N) = N_Protected_Type_Declaration)
+ then
+ if not Is_Limited_Record (Prev) then
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", N);
+
+ elsif No (Interface_List (N)) then
+ Error_Msg_N
+ ("completion of tagged private type must be tagged",
+ N);
+ end if;
end if;
-- Ada 2005 (AI-251): Private extension declaration of a
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)
then
null;
return Assoc_List;
end Inherit_Components;
+ -----------------------
+ -- Is_Null_Extension --
+ -----------------------
+
+ function Is_Null_Extension (T : Entity_Id) return Boolean is
+ Full_Type_Decl : constant Node_Id := Parent (T);
+ Full_Type_Defn : constant Node_Id := Type_Definition (Full_Type_Decl);
+ Comp_List : Node_Id;
+ First_Comp : Node_Id;
+
+ begin
+ if not Is_Tagged_Type (T)
+ or else Nkind (Full_Type_Defn) /= N_Derived_Type_Definition
+ then
+ return False;
+ end if;
+
+ Comp_List := Component_List (Record_Extension_Part (Full_Type_Defn));
+
+ if Present (Discriminant_Specifications (Full_Type_Decl)) then
+ return False;
+
+ elsif Present (Comp_List)
+ and then Is_Non_Empty_List (Component_Items (Comp_List))
+ then
+ First_Comp := First (Component_Items (Comp_List));
+
+ return Chars (Defining_Identifier (First_Comp)) = Name_uParent
+ and then No (Next (First_Comp));
+
+ else
+ return True;
+ end if;
+ end Is_Null_Extension;
+
------------------------------
-- Is_Valid_Constraint_Kind --
------------------------------
end if;
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
- Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
+ 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
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;
+
-- Implementations of the form:
-- type Typ is new Iface ...
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
- if Is_Interface (Iface)
- and then not Contain_Interface (Iface, Ifaces)
- then
+ 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);
Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
- -- Ada 2005 (AI-396): The partial view shall be a descendant of
- -- an interface type if and only if the full view is a descendant
- -- of the interface type.
+ -- 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 & not implemented by full type " &
+ "('R'M'-2005 7.3 (7.3/2))", Priv_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 " &
- "('R'M'-2005 7.3(9))", Full_T, Iface);
+ "('R'M'-2005 7.3 (7.3/2))", Full_T, Iface);
end if;
end;
end if;
then
null;
- elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
+ -- 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 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);
-- subtype of the full type must be constrained if and only if
-- the ancestor subtype of the private extension is constrained.
- elsif not Present (Discriminant_Specifications (Parent (Priv_T)))
+ elsif No (Discriminant_Specifications (Parent (Priv_T)))
and then not Has_Unknown_Discriminants (Priv_T)
and then Has_Discriminants (Base_Type (Priv_Parent))
then
if Nkind (Subt) = N_Identifier then
return Chars (Subt) = Chars (T);
+
+ -- 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
+ and then Is_Entity_Name (Prefix (Subt))
then
return (Chars (Prefix (Subt))) = Chars (T);
else
begin
-- If there is a previous partial view, no need to create a new one
+ -- If the partial view is incomplete, it is given by Prev. If it is
+ -- a private declaration, full declaration is flagged accordingly.
- if Prev /= T then
+ if Prev /= T
+ or else Has_Private_Declaration (T)
+ then
return;
elsif No (Inc_T) then
if Tagged_Present (Def) then
Make_Class_Wide_Type (Inc_T);
Set_Class_Wide_Type (T, Class_Wide_Type (Inc_T));
+ Set_Etype (Class_Wide_Type (T), T);
end if;
end if;
end Make_Incomplete_Type_Declaration;
Final_Storage_Only := not Is_Controlled (T);
+ -- Ada 2005: check whether an explicit Limited is present in a derived
+ -- type declaration.
+
+ if Nkind (Parent (Def)) = N_Derived_Type_Definition
+ and then Limited_Present (Parent (Def))
+ then
+ Set_Is_Limited_Record (T);
+ end if;
+
-- If the component list of a record type is defined by the reserved
-- word null and there is no discriminant part, then the record type has
-- no components and all records of the type are null records (RM 3.7)
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
procedure Check_Component (Comp : Node_Id);
-- Examine Unchecked_Union component for correct use of per-object
- -- constrained subtypes.
+ -- constrained subtypes, and for restrictions on finalizable components.
procedure Check_Duplicated_Export_Name (Nam : Node_Id);
-- Nam is an N_String_Literal node containing the external name set
declare
Sindic : constant Node_Id :=
Subtype_Indication (Component_Definition (Comp));
-
+ Typ : constant Entity_Id :=
+ Etype (Defining_Identifier (Comp));
begin
if Nkind (Sindic) = N_Subtype_Indication then
" constraint must be an Unchecked_Union", Comp);
end if;
end if;
+
+ if Is_Controlled (Typ) then
+ Error_Msg_N
+ ("component of unchecked union cannot be controlled", Comp);
+
+ elsif Has_Task (Typ) then
+ Error_Msg_N
+ ("component of unchecked union cannot have tasks", Comp);
+ end if;
end;
end if;
end Check_Component;
Comp : Node_Id;
begin
- if Present (Variant_Part (Clist)) then
- Error_Msg_N
- ("Unchecked_Union may not have nested variants",
- Variant_Part (Clist));
- end if;
-
if not Is_Non_Empty_List (Component_Items (Clist)) then
Error_Msg_N
("Unchecked_Union may not have empty component list",
procedure Set_Convention_From_Pragma (E : Entity_Id) is
begin
+ -- Check invalid attempt to change convention for an overridden
+ -- dispatching operation. This is Ada 2005 AI 430. Technically
+ -- this is an amendment and should only be done in Ada 2005 mode.
+ -- However, this is clearly a mistake, since the problem that is
+ -- addressed by this AI is that there is a clear gap in the RM!
+
+ if Is_Dispatching_Operation (E)
+ and then Present (Overridden_Operation (E))
+ and then C /= Convention (Overridden_Operation (E))
+ then
+ Error_Pragma_Arg
+ ("cannot change convention for " &
+ "overridden dispatching operation",
+ Arg1);
+ end if;
+
+ -- Set the convention
+
Set_Convention (E, C);
Set_Has_Convention_Pragma (E);
else
Dval := Default_Value (Formal);
- if not Present (Dval) then
+ if No (Dval) then
Error_Msg_NE
("optional formal& does not have default value!",
Arg_First_Optional_Parameter, Formal);
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
- -- Set the FIFO_Within_Priorities policy, but always
- -- preserve System_Location since we like the error
- -- message with the run time name.
+ -- Set the FIFO_Within_Priorities policy, but always preserve
+ -- System_Location since we like the error message with the run time
+ -- name.
else
Task_Dispatching_Policy := 'F';
Error_Msg_Sloc := Locking_Policy_Sloc;
Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
- -- Set the Ceiling_Locking policy, but always preserve
- -- System_Location since we like the error message with the
- -- run time name.
+ -- Set the Ceiling_Locking policy, but preserve System_Location since
+ -- we like the error message with the run time name.
else
Locking_Policy := 'C';
begin
if not Is_Pragma_Name (Chars (N)) then
if Warn_On_Unrecognized_Pragma then
- Error_Pragma ("unrecognized pragma%!?");
+ Error_Pragma ("unrecognized pragma%?");
else
return;
end if;
Ada_Version_Explicit := Ada_Version;
Check_Arg_Count (0);
- ------------
- -- Ada_05 --
- ------------
+ ---------------------
+ -- Ada_05/Ada_2005 --
+ ---------------------
-- pragma Ada_05;
-- pragma Ada_05 (LOCAL_NAME);
- -- Note: this pragma also has some specific processing in Par.Prag
+ -- pragma Ada_2005;
+ -- pragma Ada_2005 (LOCAL_NAME):
+
+ -- Note: these pragma also have some specific processing in Par.Prag
-- because we want to set the Ada 2005 version mode during parsing.
- when Pragma_Ada_05 => declare
+ when Pragma_Ada_05 | Pragma_Ada_2005 => declare
E_Id : Node_Id;
begin
else
Check_Arg_Count (0);
Ada_Version := Ada_05;
- Ada_Version_Explicit := Ada_Version;
+ Ada_Version_Explicit := Ada_05;
end if;
end;
procedure Process_Async_Pragma is
begin
- if not Present (L) then
+ if No (L) then
Set_Is_Asynchronous (Nm);
return;
end if;
("only tagged records can contain vtable pointers", Arg1);
end if;
- -- Case of tagged type with no vtable ptr
-
- -- What is test for Typ = Root_Typ (Typ) about here ???
+ -- Case of tagged type with no user-defined vtable ptr. In this
+ -- case, because of our C++ ABI compatibility, the programmer
+ -- does not need to specify the tag component.
elsif Is_Tagged_Type (Typ)
- and then Typ = Root_Type (Typ)
and then No (Default_DTC)
then
- Error_Pragma_Arg
- ("a cpp_class must contain a vtable pointer", Arg1);
+ Set_Is_CPP_Class (Typ);
+ Set_Is_Limited_Record (Typ);
-- Tagged type that has a vtable ptr
Next_Component (DTC);
end loop;
+ -- Case of tagged type with no user-defined vtable ptr
+
if No (DTC) then
Error_Msg_NE ("must be a& component name", Arg, Typ);
raise Pragma_Exit;
-- No_Return --
---------------
- -- pragma No_Return (procedure_LOCAL_NAME);
+ -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
when Pragma_No_Return => No_Return : declare
Id : Node_Id;
E : Entity_Id;
Found : Boolean;
+ Arg : Node_Id;
begin
GNAT_Pragma;
- Check_Arg_Count (1);
- Check_No_Identifiers;
- Check_Arg_Is_Local_Name (Arg1);
- Id := Expression (Arg1);
- Analyze (Id);
+ Check_At_Least_N_Arguments (1);
- if not Is_Entity_Name (Id) then
- Error_Pragma_Arg ("entity name required", Arg1);
- end if;
+ -- Loop through arguments of pragma
- if Etype (Id) = Any_Type then
- raise Pragma_Exit;
- end if;
+ Arg := Arg1;
+ while Present (Arg) loop
+ Check_Arg_Is_Local_Name (Arg);
+ Id := Expression (Arg);
+ Analyze (Id);
- E := Entity (Id);
+ if not Is_Entity_Name (Id) then
+ Error_Pragma_Arg ("entity name required", Arg);
+ end if;
- Found := False;
- while Present (E)
- and then Scope (E) = Current_Scope
- loop
- if Ekind (E) = E_Procedure
- or else Ekind (E) = E_Generic_Procedure
- then
- Set_No_Return (E);
- Found := True;
+ if Etype (Id) = Any_Type then
+ raise Pragma_Exit;
end if;
- E := Homonym (E);
- end loop;
+ -- Loop to find matching procedures
- if not Found then
- Error_Pragma ("no procedures found for pragma%");
- end if;
+ E := Entity (Id);
+ Found := False;
+ while Present (E)
+ and then Scope (E) = Current_Scope
+ loop
+ if Ekind (E) = E_Procedure
+ or else Ekind (E) = E_Generic_Procedure
+ then
+ Set_No_Return (E);
+ Found := True;
+ end if;
+
+ E := Homonym (E);
+ end loop;
+
+ if not Found then
+ Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
+ end if;
+
+ Next (Arg);
+ end loop;
end No_Return;
------------------------
-- Obsolescent --
-----------------
- -- pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])];
+ -- pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])];
when Pragma_Obsolescent => Obsolescent : declare
Subp : Node_Or_Entity_Id;
-- pragma Propagate_Exceptions;
+ -- Note: this pragma is obsolete and has no effect
+
when Pragma_Propagate_Exceptions =>
GNAT_Pragma;
Check_Arg_Count (0);
Ent := Find_Lib_Unit_Name;
Set_Is_Pure (Ent);
+ Set_Has_Pragma_Pure (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end Pure;
Discr := First_Discriminant (Typ);
- if Present (Next_Discriminant (Discr)) then
- Error_Msg_N
- ("Unchecked_Union must have exactly one discriminant",
- Next_Discriminant (Discr));
- return;
- end if;
-
- if No (Discriminant_Default_Value (Discr)) then
- Error_Msg_N
- ("Unchecked_Union discriminant must have default value",
- Discr);
- end if;
+ while Present (Discr) loop
+ if No (Discriminant_Default_Value (Discr)) then
+ Error_Msg_N
+ ("Unchecked_Union discriminant must have default value",
+ Discr);
+ end if;
+ Next_Discriminant (Discr);
+ end loop;
Tdef := Type_Definition (Declaration_Node (Typ));
Clist := Component_List (Tdef);
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
+ Pragma_Ada_2005 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,
OSDN Git Service
