diff options
| -rw-r--r-- | gcc/ada/libgnat/g-exptty.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/libgnat/g-exptty.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 25 |
5 files changed, 47 insertions, 12 deletions
diff --git a/gcc/ada/libgnat/g-exptty.adb b/gcc/ada/libgnat/g-exptty.adb index ae2d64a..bc239e4 100644 --- a/gcc/ada/libgnat/g-exptty.adb +++ b/gcc/ada/libgnat/g-exptty.adb @@ -314,9 +314,9 @@ package body GNAT.Expect.TTY is overriding procedure Set_Up_Communications (Pid : in out TTY_Process_Descriptor; Err_To_Out : Boolean; - Pipe1 : access Pipe_Type; - Pipe2 : access Pipe_Type; - Pipe3 : access Pipe_Type) + Pipe1 : not null access Pipe_Type; + Pipe2 : not null access Pipe_Type; + Pipe3 : not null access Pipe_Type) is pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3); diff --git a/gcc/ada/libgnat/g-exptty.ads b/gcc/ada/libgnat/g-exptty.ads index 5f1736c..ede147c 100644 --- a/gcc/ada/libgnat/g-exptty.ads +++ b/gcc/ada/libgnat/g-exptty.ads @@ -116,9 +116,9 @@ private procedure Set_Up_Communications (Pid : in out TTY_Process_Descriptor; Err_To_Out : Boolean; - Pipe1 : access Pipe_Type; - Pipe2 : access Pipe_Type; - Pipe3 : access Pipe_Type); + Pipe1 : not null access Pipe_Type; + Pipe2 : not null access Pipe_Type; + Pipe3 : not null access Pipe_Type); procedure Set_Up_Parent_Communications (Pid : in out TTY_Process_Descriptor; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 860db03..69494a0 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -11177,6 +11177,18 @@ package body Sem_Ch6 is Inherit_Subprogram_Contract (E, S); end if; + -- When a dispatching operation overrides an inherited + -- subprogram, it shall be subtype conformant with the + -- inherited subprogram (RM 3.9.2 (10.2)). + + if Comes_From_Source (E) + and then Is_Dispatching_Operation (E) + and then Find_Dispatching_Type (S) + = Find_Dispatching_Type (E) + then + Check_Subtype_Conformant (E, S); + end if; + if Comes_From_Source (E) then Check_Overriding_Indicator (E, S, Is_Primitive => False); diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads index 1953930..993ec10 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.ads @@ -64,11 +64,11 @@ package Sem_Disp is -- this call actually do??? procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id); - -- Add Old_Subp to the list of primitive operations of the corresponding - -- tagged type if it is the full view of a private tagged type. The Alias - -- of Old_Subp is adjusted to point to the inherited procedure of the - -- full view because it is always this one which has to be called. - -- What is Subp used for??? + -- No action performed if Subp is not an alias of a dispatching operation. + -- Add Old_Subp (if not already present) to the list of primitives of the + -- tagged type T of Subp if T is the full view of a private tagged type. + -- The Alias of Old_Subp is adjusted to point to the inherited procedure + -- of the full view because it is always this one which has to be called. function Covered_Interface_Op (Prim : Entity_Id) return Entity_Id; -- Returns the interface primitive that Prim covers, when its controlling diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 2857c53..879f0c1 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -6092,6 +6092,29 @@ package body Sem_Eval is elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then + -- Handle derivations of private subtypes. For example S1 statically + -- matches the full view of T1 in the following example: + + -- type T1(<>) is new Root with private; + -- subtype S1 is new T1; + -- overriding proc P1 (P : S1); + -- private + -- type T1 (D : Disc) is new Root with ... + + if Ekind (T2) = E_Record_Subtype_With_Private + and then not Has_Discriminants (T2) + and then Partial_View_Has_Unknown_Discr (T1) + and then Etype (T2) = T1 + then + return True; + + elsif Ekind (T1) = E_Record_Subtype_With_Private + and then not Has_Discriminants (T1) + and then Partial_View_Has_Unknown_Discr (T2) + and then Etype (T1) = T2 + then + return True; + -- Because of view exchanges in multiple instantiations, conformance -- checking might try to match a partial view of a type with no -- discriminants with a full view that has defaulted discriminants. @@ -6099,7 +6122,7 @@ package body Sem_Eval is -- which must exist because we know that the two subtypes have the -- same base type. - if Has_Discriminants (T1) /= Has_Discriminants (T2) then + elsif Has_Discriminants (T1) /= Has_Discriminants (T2) then if In_Instance then if Is_Private_Type (T2) and then Present (Full_View (T2)) |