+2015-05-26 Yannick Moy <moy@adacore.com>
+
+ * sem_aux.adb, sem_aux.ads (Get_Low_Bound): Use Type_Low_Bound.
+ (Package_Body, Package_Spec): New queries moved
+ here from GNATprove.
+ (Package_Specification): Simplify query to remove use of loop.
+ * sem_util.adb, sem_util.ads (Enclosing_Declaration,
+ Enclosing_Package_Or_Subprogram, Is_Attribute_Update): New
+ queries moved here from GNATprove.
+
2015-05-26 Bob Duff <duff@adacore.com>
* einfo.adb, einfo.ads, sprint.adb, lib-xref.ads: Minor cleanup: Remove
if Ekind (E) = E_String_Literal_Subtype then
return String_Literal_Low_Bound (E);
else
- -- Why is this not Type_Low_Bound (E)???
- return Low_Bound (Scalar_Range (E));
+ return Type_Low_Bound (E);
end if;
end Get_Low_Bound;
end if;
end Is_By_Reference_Type;
- ---------------------------
+ -------------------------
-- Is_Definite_Subtype --
- ---------------------------
+ -------------------------
function Is_Definite_Subtype (T : Entity_Id) return Boolean is
pragma Assert (Is_Type (T));
and then Has_Discriminants (Typ));
end Object_Type_Has_Constrained_Partial_View;
+ ------------------
+ -- Package_Body --
+ ------------------
+
+ function Package_Body (E : Entity_Id) return Node_Id is
+ N : Node_Id;
+
+ begin
+ if Ekind (E) = E_Package_Body then
+ N := Parent (E);
+
+ if Nkind (N) = N_Defining_Program_Unit_Name then
+ N := Parent (N);
+ end if;
+
+ else
+ N := Package_Spec (E);
+
+ if Present (Corresponding_Body (N)) then
+ N := Parent (Corresponding_Body (N));
+
+ if Nkind (N) = N_Defining_Program_Unit_Name then
+ N := Parent (N);
+ end if;
+ else
+ N := Empty;
+ end if;
+ end if;
+
+ return N;
+ end Package_Body;
+
+ ------------------
+ -- Package_Spec --
+ ------------------
+
+ function Package_Spec (E : Entity_Id) return Node_Id is
+ begin
+ return Parent (Package_Specification (E));
+ end Package_Spec;
+
---------------------------
-- Package_Specification --
---------------------------
- function Package_Specification (Pack_Id : Entity_Id) return Node_Id is
+ function Package_Specification (E : Entity_Id) return Node_Id is
N : Node_Id;
begin
- N := Parent (Pack_Id);
- while Nkind (N) /= N_Package_Specification loop
- N := Parent (N);
+ N := Parent (E);
- if No (N) then
- raise Program_Error;
- end if;
- end loop;
+ if Nkind (N) = N_Defining_Program_Unit_Name then
+ N := Parent (N);
+ end if;
return N;
end Package_Specification;
-- If this declaration is not a subprogram body, then it must be a
-- subprogram declaration, from which we can retrieve the entity for
- -- the corresponding subprogram body if any.
+ -- the corresponding subprogram body if any, or an abstract subprogram
+ -- declaration, for which we return Empty.
- if Nkind (N) = N_Subprogram_Body then
- return E;
- else
- return Corresponding_Body (N);
- end if;
+ case Nkind (N) is
+ when N_Subprogram_Body =>
+ return E;
+
+ when N_Subprogram_Declaration =>
+ return Corresponding_Body (N);
+
+ when others =>
+ return Empty;
+ end case;
end Subprogram_Body_Entity;
---------------------
-- derived type, and the subtype is not an unconstrained array subtype
-- (RM 3.3(23.10/3)).
- function Package_Specification (Pack_Id : Entity_Id) return Node_Id;
- -- Given an entity for a package or generic package, return corresponding
- -- package specification. Simplifies handling of child units, and better
- -- than the old idiom: Specification (Unit_Declaration_Node (Pack_Id)).
+ function Package_Body (E : Entity_Id) return Node_Id;
+ -- Given an entity for a package (spec or body), return the corresponding
+ -- package body if any, or else Empty.
+
+ function Package_Spec (E : Entity_Id) return Node_Id;
+ -- Given an entity for a package spec, return the corresponding package
+ -- spec if any, or else Empty.
+
+ function Package_Specification (E : Entity_Id) return Node_Id;
+ -- Given an entity for a package, return the corresponding package
+ -- specification.
function Subprogram_Body (E : Entity_Id) return Node_Id;
-- Given an entity for a subprogram (spec or body), return the
end if;
end Enclosing_Comp_Unit_Node;
- -----------------------------
- -- Enclosing_Lib_Unit_Node --
- -----------------------------
-
- function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
- Encl_Unit : Node_Id;
-
- begin
- Encl_Unit := Enclosing_Comp_Unit_Node (N);
- while Present (Encl_Unit)
- and then Nkind (Unit (Encl_Unit)) = N_Subunit
- loop
- Encl_Unit := Library_Unit (Encl_Unit);
- end loop;
-
- return Encl_Unit;
- end Enclosing_Lib_Unit_Node;
-
--------------------------
-- Enclosing_CPP_Parent --
--------------------------
return Parent_Typ;
end Enclosing_CPP_Parent;
+ ---------------------------
+ -- Enclosing_Declaration --
+ ---------------------------
+
+ function Enclosing_Declaration (N : Node_Id) return Node_Id is
+ Decl : Node_Id := N;
+
+ begin
+ while Present (Decl)
+ and then not (Nkind (Decl) in N_Declaration
+ or else
+ Nkind (Decl) in N_Later_Decl_Item)
+ loop
+ Decl := Parent (Decl);
+ end loop;
+
+ return Decl;
+ end Enclosing_Declaration;
+
----------------------------
-- Enclosing_Generic_Body --
----------------------------
return Unit_Entity;
end Enclosing_Lib_Unit_Entity;
+ -----------------------------
+ -- Enclosing_Lib_Unit_Node --
+ -----------------------------
+
+ function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
+ Encl_Unit : Node_Id;
+
+ begin
+ Encl_Unit := Enclosing_Comp_Unit_Node (N);
+ while Present (Encl_Unit)
+ and then Nkind (Unit (Encl_Unit)) = N_Subunit
+ loop
+ Encl_Unit := Library_Unit (Encl_Unit);
+ end loop;
+
+ return Encl_Unit;
+ end Enclosing_Lib_Unit_Node;
+
-----------------------
-- Enclosing_Package --
-----------------------
end if;
end Enclosing_Package;
+ -------------------------------------
+ -- Enclosing_Package_Or_Subprogram --
+ -------------------------------------
+
+ function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is
+ S : Entity_Id;
+
+ begin
+ S := Scope (E);
+ while Present (S) loop
+ if Is_Package_Or_Generic_Package (S)
+ or else Ekind (S) = E_Package_Body
+ then
+ return S;
+
+ elsif Is_Subprogram_Or_Generic_Subprogram (S)
+ or else Ekind (S) = E_Subprogram_Body
+ then
+ return S;
+
+ else
+ S := Scope (S);
+ end if;
+ end loop;
+
+ return Empty;
+ end Enclosing_Package_Or_Subprogram;
+
--------------------------
-- Enclosing_Subprogram --
--------------------------
and then Attribute_Name (N) = Name_Result;
end Is_Attribute_Result;
+ -------------------------
+ -- Is_Attribute_Update --
+ -------------------------
+
+ function Is_Attribute_Update (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Update;
+ end Is_Attribute_Update;
+
------------------------------------
-- Is_Body_Or_Package_Declaration --
------------------------------------
-- Returns the enclosing N_Compilation_Unit node that is the root of a
-- subtree containing N.
- function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id;
- -- Returns the N_Compilation_Unit node of the library unit that is directly
- -- or indirectly (through a subunit) at the root of a subtree containing
- -- N. This may be either the same as Enclosing_Comp_Unit_Node, or if
- -- Enclosing_Comp_Unit_Node returns a subunit, then the corresponding
- -- library unit. If no such item is found, returns Empty???
-
function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id;
-- Returns the closest ancestor of Typ that is a CPP type.
+ function Enclosing_Declaration (N : Node_Id) return Node_Id;
+ -- Returns the declaration node enclosing N, if any, or Empty otherwise
+
function Enclosing_Generic_Body
(N : Node_Id) return Node_Id;
-- Returns the Node_Id associated with the innermost enclosing generic
-- caller is responsible for ensuring this condition) or other specified
-- entity.
+ function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id;
+ -- Returns the N_Compilation_Unit node of the library unit that is directly
+ -- or indirectly (through a subunit) at the root of a subtree containing
+ -- N. This may be either the same as Enclosing_Comp_Unit_Node, or if
+ -- Enclosing_Comp_Unit_Node returns a subunit, then the corresponding
+ -- library unit. If no such item is found, returns Empty.
+
function Enclosing_Package (E : Entity_Id) return Entity_Id;
-- Utility function to return the Ada entity of the package enclosing
-- the entity E, if any. Returns Empty if no enclosing package.
+ function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id;
+ -- Returns the entity of the package or subprogram enclosing E, if any.
+ -- Returns Empty if no enclosing package or subprogram.
+
function Enclosing_Subprogram (E : Entity_Id) return Entity_Id;
-- Utility function to return the Ada entity of the subprogram enclosing
-- the entity E, if any. Returns Empty if no enclosing subprogram.
function Is_Attribute_Result (N : Node_Id) return Boolean;
-- Determine whether node N denotes attribute 'Result
+ function Is_Attribute_Update (N : Node_Id) return Boolean;
+ -- Determine whether node N denotes attribute 'Update
+
function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean;
-- Determine whether node N denotes a body or a package declaration
projects / gcc.git / commitdiff