diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 175 |
1 files changed, 175 insertions, 0 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 15e6a64..d2d8a41 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8324,6 +8324,181 @@ package body Sem_Util is Is_RTE (Root_Type (Under), RO_WW_Super_String)); end Is_Bounded_String; + ------------------------- + -- Is_Child_Or_Sibling -- + ------------------------- + + function Is_Child_Or_Sibling + (Pack_1 : Entity_Id; + Pack_2 : Entity_Id; + Private_Child : Boolean) return Boolean + is + function Distance_From_Standard (Pack : Entity_Id) return Nat; + -- Given an arbitrary package, return the number of "climbs" necessary + -- to reach scope Standard_Standard. + + procedure Equalize_Depths + (Pack : in out Entity_Id; + Depth : in out Nat; + Depth_To_Reach : Nat); + -- Given an arbitrary package, its depth and a target depth to reach, + -- climb the scope chain until the said depth is reached. The pointer + -- to the package and its depth a modified during the climb. + + function Is_Child (Pack : Entity_Id) return Boolean; + -- Given a package Pack, determine whether it is a child package that + -- satisfies the privacy requirement (if set). + + ---------------------------- + -- Distance_From_Standard -- + ---------------------------- + + function Distance_From_Standard (Pack : Entity_Id) return Nat is + Dist : Nat; + Scop : Entity_Id; + + begin + Dist := 0; + Scop := Pack; + while Present (Scop) and then Scop /= Standard_Standard loop + Dist := Dist + 1; + Scop := Scope (Scop); + end loop; + + return Dist; + end Distance_From_Standard; + + --------------------- + -- Equalize_Depths -- + --------------------- + + procedure Equalize_Depths + (Pack : in out Entity_Id; + Depth : in out Nat; + Depth_To_Reach : Nat) + is + begin + -- The package must be at a greater or equal depth + + if Depth < Depth_To_Reach then + raise Program_Error; + end if; + + -- Climb the scope chain until the desired depth is reached + + while Present (Pack) and then Depth /= Depth_To_Reach loop + Pack := Scope (Pack); + Depth := Depth - 1; + end loop; + end Equalize_Depths; + + -------------- + -- Is_Child -- + -------------- + + function Is_Child (Pack : Entity_Id) return Boolean is + begin + if Is_Child_Unit (Pack) then + if Private_Child then + return Is_Private_Descendant (Pack); + else + return True; + end if; + + -- The package is nested, it cannot act a child or a sibling + + else + return False; + end if; + end Is_Child; + + -- Local variables + + P_1 : Entity_Id := Pack_1; + P_1_Child : Boolean := False; + P_1_Depth : Nat := Distance_From_Standard (P_1); + P_2 : Entity_Id := Pack_2; + P_2_Child : Boolean := False; + P_2_Depth : Nat := Distance_From_Standard (P_2); + + -- Start of processing for Is_Child_Or_Sibling + + begin + pragma Assert + (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package); + + -- Both packages denote the same entity, therefore they cannot be + -- children or siblings. + + if P_1 = P_2 then + return False; + + -- One of the packages is at a deeper level than the other. Note that + -- both may still come from differen hierarchies. + + -- (root) P_2 + -- / \ : + -- X P_2 or X + -- : : + -- P_1 P_1 + + elsif P_1_Depth > P_2_Depth then + Equalize_Depths (P_1, P_1_Depth, P_2_Depth); + P_1_Child := True; + + -- (root) P_1 + -- / \ : + -- P_1 X or X + -- : : + -- P_2 P_2 + + elsif P_2_Depth > P_1_Depth then + Equalize_Depths (P_2, P_2_Depth, P_1_Depth); + P_2_Child := True; + end if; + + -- At this stage the package pointers have been elevated to the same + -- depth. If the related entities are the same, then one package is a + -- potential child of the other: + + -- P_1 + -- : + -- X became P_1 P_2 or vica versa + -- : + -- P_2 + + if P_1 = P_2 then + if P_1_Child then + return Is_Child (Pack_1); + else pragma Assert (P_2_Child); + return Is_Child (Pack_2); + end if; + + -- The packages may come from the same package chain or from entirely + -- different hierarcies. To determine this, climb the scope stack until + -- a common root is found. + + -- (root) (root 1) (root 2) + -- / \ | | + -- P_1 P_2 P_1 P_2 + + else + while Present (P_1) and then Present (P_2) loop + + -- The two packages may be siblings + + if P_1 = P_2 then + return Is_Child (Pack_1) and then Is_Child (Pack_2); + end if; + + P_1 := Scope (P_1); + P_2 := Scope (P_2); + end loop; + end if; + + return False; + end Is_Child_Or_Sibling; + ----------------------------- -- Is_Concurrent_Interface -- ----------------------------- |