diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 27 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 26 |
6 files changed, 77 insertions, 8 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0bce664..9d5222b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2015-05-27 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Process_Formals): A non-private formal type that + is a limited view does not have a list of private dependents. + +2015-05-27 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_N_Case_Statement): If the expression in + the case statement is a compile-time known value, we look for a + corresponding alternative to optimize the case statement into a + single case. If the type has a static predicate and the expression + does not satisfy the predicate, there is no legal alternative and + this optimization is not applicable. Excecution is erroneous, + or else if assertions are enabled, an exception will be raised + earlier, at the point the expression is elaborated. + +2015-05-27 Robert Dewar <dewar@adacore.com> + + * sem_elab.adb (Check_Internal_Call_Continue): Suppress + warning on Finalize, Adjust, or Initialize if type involved has + Warnings_Off set. + +2015-05-27 Ed Schonberg <schonberg@adacore.com> + + * sem_aux.adb, sem_aux.ads (First_Discriminant): Return empty when + applied to a type with no known discriminants. + 2015-05-26 Robert Dewar <dewar@adacore.com> * errout.ads, sem_ch4.adb, sem_ch6.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index ca6971e..7156c76 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2586,9 +2586,16 @@ package body Exp_Ch5 is begin -- Check for the situation where we know at compile time which branch - -- will be taken + -- will be taken. - if Compile_Time_Known_Value (Expr) then + -- If the value is static but its subtype is predicated and the value + -- does not obey the predicate, the value is marked non-static, and + -- there can be no corresponding static alternative. + + if Compile_Time_Known_Value (Expr) + and then (not Has_Predicates (Etype (Expr)) + or else Is_Static_Expression (Expr)) + then Alt := Find_Static_Alternative (N); -- Do not consider controlled objects found in a case statement which diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 31644b0..32d5b1f 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -246,7 +246,12 @@ package body Sem_Aux is Ent := Next_Entity (Ent); end loop; - pragma Assert (Ekind (Ent) = E_Discriminant); + -- Call may be on a private type with unknown discriminants, in which + -- case Ent is Empty, and as per the spec, we return Empty in this case. + + -- Historical note: The revious assertion that Ent is a discriminant + -- was overly cautious and prevented application of this function in + -- SPARK applications. return Ent; end First_Discriminant; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 5268b01..db0931e 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -119,9 +119,9 @@ package Sem_Aux is -- First_Entity. The exception arises for tagged types, where the tag -- itself is prepended to the front of the entity chain, so the -- First_Discriminant function steps past the tag if it is present. - -- The caller is responsible for checking that the type has discriminants, - -- so for example it is improper to call this function on a private - -- type with unknown discriminants. + -- The caller is responsible for checking that the type has discriminants. + -- When called on a private type with unknown discriminants, the function + -- always returns Empty. function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id; -- Typ is a type with discriminants. Gives the first discriminant stored diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 43cbffc..18a9b02 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -10117,9 +10117,13 @@ package body Sem_Ch6 is (Parent (T), N_Access_Function_Definition, N_Access_Procedure_Definition) then - if not Is_Class_Wide_Type (Formal_Type) then + -- A limited view has no private dependents + + if not Is_Class_Wide_Type (Formal_Type) + and then not From_Limited_With (Formal_Type) + then Append_Elmt (Current_Scope, - Private_Dependents (Base_Type (Formal_Type))); + Private_Dependents (Base_Type (Formal_Type))); end if; -- Freezing is delayed to ensure that Register_Prim diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 07517bb..01fd0cd 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -2447,6 +2447,30 @@ package body Sem_Elab is ("instantiation of& may occur before body is seen<l<", N, Orig_Ent); else + -- A rather specific check. For Finalize/Adjust/Initialize, + -- if the type has Warnings_Off set, suppress the warning. + + if Nam_In (Chars (E), Name_Adjust, + Name_Finalize, + Name_Initialize) + and then Present (First_Formal (E)) + then + declare + T : constant Entity_Id := Etype (First_Formal (E)); + begin + if Is_Controlled (T) then + if Warnings_Off (T) + or else (Ekind (T) = E_Private_Type + and then Warnings_Off (Full_View (T))) + then + goto Output; + end if; + end if; + end; + end if; + + -- Go ahead and give warning if not this special case + Error_Msg_NE ("call to& may occur before body is seen<l<", N, Orig_Ent); end if; @@ -2458,6 +2482,8 @@ package body Sem_Elab is -- all the clarification messages produces by Output_Calls must be -- emitted unconditionally. + <<Output>> + Output_Calls (N, Check_Elab_Flag => False); end if; end if; |