From: Arnaud Charlet Date: Tue, 2 Aug 2011 12:26:47 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=12f0c50ca93bed7c589750e20df7977787e0ea07;p=gcc.git [multiple changes] 2011-08-02 Geert Bosch * a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image. 2011-08-02 Eric Botcazou * sem_type.adb (Covers): Move trivial case to the top and reuse the computed value of Base_Type. 2011-08-02 Yannick Moy * restrict.adb (Check_Restriction): issue an error for any use of class-wide, even if the No_Dispatch restriction is not set. * sem_aggr.adb: Correct typos in comments and messages in formal mode * sem_ch3.adb (Process_Full_View): issue an error in formal mode is, when completing a private extension, the type named in the private part is not the same as that named in the visible part. * sem_res.adb (Resolve_Call): issue an error in formal mode on the use of an inherited primitive operations of a tagged type or type extension that returns the tagged type. * sem_util.adb, sem_util.ads (Is_Inherited_Operation_For_Type): new function which returns True for an implicit operation inherited by the derived type declaration for the argument type. (Is_SPARK_Object_Reference): move to appropriate place in alphabetic order. From-SVN: r177135 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 858a947a124..9ba947a1dc1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2011-08-02 Geert Bosch + + * a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image. + +2011-08-02 Eric Botcazou + + * sem_type.adb (Covers): Move trivial case to the top and reuse the + computed value of Base_Type. + +2011-08-02 Yannick Moy + + * restrict.adb (Check_Restriction): issue an error for any use of + class-wide, even if the No_Dispatch restriction is not set. + * sem_aggr.adb: Correct typos in comments and messages in formal mode + * sem_ch3.adb (Process_Full_View): issue an error in formal mode is, + when completing a private extension, the type named in the private part + is not the same as that named in the visible part. + * sem_res.adb (Resolve_Call): issue an error in formal mode on the use + of an inherited primitive operations of a tagged type or type extension + that returns the tagged type. + * sem_util.adb, sem_util.ads (Is_Inherited_Operation_For_Type): new + function which returns True for an implicit operation inherited by the + derived type declaration for the argument type. + (Is_SPARK_Object_Reference): move to appropriate place in alphabetic + order. + 2011-08-02 Ed Schonberg * sem_ch5.adb (Pre_Analyze_Range): new procedure extracted from diff --git a/gcc/ada/a-calfor.adb b/gcc/ada/a-calfor.adb index 39c3c0a2f79..41f8c2595dd 100644 --- a/gcc/ada/a-calfor.adb +++ b/gcc/ada/a-calfor.adb @@ -139,83 +139,53 @@ package body Ada.Calendar.Formatting is (Elapsed_Time : Duration; Include_Time_Fraction : Boolean := False) return String is + To_Char : constant array (0 .. 9) of Character := "0123456789"; Hour : Hour_Number; Minute : Minute_Number; Second : Second_Number; Sub_Second : Duration; SS_Nat : Natural; - Low : Integer; - High : Integer; + -- Determine the two slice bounds for the result string depending on + -- whether the input is negative and whether fractions are requested. + + First : constant Integer := (if Elapsed_Time < 0.0 then 1 else 2); + Last : constant Integer := (if Include_Time_Fraction then 12 else 9); Result : String := "-00:00:00.00"; begin Split (abs (Elapsed_Time), Hour, Minute, Second, Sub_Second); - -- Determine the two slice bounds for the result string depending on - -- whether the input is negative and whether fractions are requested. + -- Hour processing, positions 2 and 3 - Low := (if Elapsed_Time < 0.0 then 1 else 2); - High := (if Include_Time_Fraction then 12 else 9); + Result (2) := To_Char (Hour / 10); + Result (3) := To_Char (Hour mod 10); - -- Prevent rounding when converting to natural + -- Minute processing, positions 5 and 6 - Sub_Second := Sub_Second * 100.0; + Result (5) := To_Char (Minute / 10); + Result (6) := To_Char (Minute mod 10); - if Sub_Second > 0.0 then - Sub_Second := Sub_Second - 0.5; - end if; + -- Second processing, positions 8 and 9 - SS_Nat := Natural (Sub_Second); + Result (8) := To_Char (Second / 10); + Result (9) := To_Char (Second mod 10); - declare - Hour_Str : constant String := Hour_Number'Image (Hour); - Minute_Str : constant String := Minute_Number'Image (Minute); - Second_Str : constant String := Second_Number'Image (Second); - SS_Str : constant String := Natural'Image (SS_Nat); + -- Optional sub second processing, positions 11 and 12 - begin - -- Hour processing, positions 2 and 3 + if Include_Time_Fraction and then Sub_Second > 0.0 then - if Hour < 10 then - Result (3) := Hour_Str (2); - else - Result (2) := Hour_Str (2); - Result (3) := Hour_Str (3); - end if; - - -- Minute processing, positions 5 and 6 + -- Prevent rounding up when converting to natural, avoiding the zero + -- case to prevent rounding down to a negative number. - if Minute < 10 then - Result (6) := Minute_Str (2); - else - Result (5) := Minute_Str (2); - Result (6) := Minute_Str (3); - end if; + SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5); - -- Second processing, positions 8 and 9 - - if Second < 10 then - Result (9) := Second_Str (2); - else - Result (8) := Second_Str (2); - Result (9) := Second_Str (3); - end if; - - -- Optional sub second processing, positions 11 and 12 - - if Include_Time_Fraction then - if SS_Nat < 10 then - Result (12) := SS_Str (2); - else - Result (11) := SS_Str (2); - Result (12) := SS_Str (3); - end if; - end if; + Result (11) := To_Char (SS_Nat / 10); + Result (12) := To_Char (SS_Nat mod 10); + end if; - return Result (Low .. High); - end; + return Result (First .. Last); end Image; ----------- @@ -227,6 +197,8 @@ package body Ada.Calendar.Formatting is Include_Time_Fraction : Boolean := False; Time_Zone : Time_Zones.Time_Offset := 0) return String is + To_Char : constant array (0 .. 9) of Character := "0123456789"; + Year : Year_Number; Month : Month_Number; Day : Day_Number; @@ -237,99 +209,60 @@ package body Ada.Calendar.Formatting is SS_Nat : Natural; Leap_Second : Boolean; + -- The result length depends on whether fractions are requested. + Result : String := "0000-00-00 00:00:00.00"; + Last : constant Positive + := Result'Last - (if Include_Time_Fraction then 0 else 3); begin Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second, Leap_Second, Time_Zone); - -- Prevent rounding when converting to natural - - Sub_Second := Sub_Second * 100.0; - - if Sub_Second > 0.0 then - Sub_Second := Sub_Second - 0.5; - end if; - - SS_Nat := Natural (Sub_Second); + -- Year processing, positions 1, 2, 3 and 4 - declare - Year_Str : constant String := Year_Number'Image (Year); - Month_Str : constant String := Month_Number'Image (Month); - Day_Str : constant String := Day_Number'Image (Day); - Hour_Str : constant String := Hour_Number'Image (Hour); - Minute_Str : constant String := Minute_Number'Image (Minute); - Second_Str : constant String := Second_Number'Image (Second); - SS_Str : constant String := Natural'Image (SS_Nat); + Result (1) := To_Char (Year / 1000); + Result (2) := To_Char (Year / 100 mod 10); + Result (3) := To_Char (Year / 10 mod 10); + Result (4) := To_Char (Year mod 10); - begin - -- Year processing, positions 1, 2, 3 and 4 + -- Month processing, positions 6 and 7 - Result (1) := Year_Str (2); - Result (2) := Year_Str (3); - Result (3) := Year_Str (4); - Result (4) := Year_Str (5); + Result (6) := To_Char (Month / 10); + Result (7) := To_Char (Month mod 10); - -- Month processing, positions 6 and 7 + -- Day processing, positions 9 and 10 - if Month < 10 then - Result (7) := Month_Str (2); - else - Result (6) := Month_Str (2); - Result (7) := Month_Str (3); - end if; + Result (9) := To_Char (Day / 10); + Result (10) := To_Char (Day mod 10); - -- Day processing, positions 9 and 10 + Result (12) := To_Char (Hour / 10); + Result (13) := To_Char (Hour mod 10); - if Day < 10 then - Result (10) := Day_Str (2); - else - Result (9) := Day_Str (2); - Result (10) := Day_Str (3); - end if; + -- Minute processing, positions 15 and 16 - -- Hour processing, positions 12 and 13 + Result (15) := To_Char (Minute / 10); + Result (16) := To_Char (Minute mod 10); - if Hour < 10 then - Result (13) := Hour_Str (2); - else - Result (12) := Hour_Str (2); - Result (13) := Hour_Str (3); - end if; + -- Second processing, positions 18 and 19 - -- Minute processing, positions 15 and 16 + Result (18) := To_Char (Second / 10); + Result (19) := To_Char (Second mod 10); - if Minute < 10 then - Result (16) := Minute_Str (2); - else - Result (15) := Minute_Str (2); - Result (16) := Minute_Str (3); - end if; + -- Optional sub second processing, positions 21 and 22 - -- Second processing, positions 18 and 19 + if Include_Time_Fraction and then Sub_Second > 0.0 then - if Second < 10 then - Result (19) := Second_Str (2); - else - Result (18) := Second_Str (2); - Result (19) := Second_Str (3); - end if; + -- Prevent rounding up when converting to natural, avoiding the zero + -- case to prevent rounding down to a negative number. - -- Optional sub second processing, positions 21 and 22 + SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5); - if Include_Time_Fraction then - if SS_Nat < 10 then - Result (22) := SS_Str (2); - else - Result (21) := SS_Str (2); - Result (22) := SS_Str (3); - end if; + Result (21) := To_Char (SS_Nat / 10); + Result (22) := To_Char (SS_Nat mod 10); + end if; - return Result; - else - return Result (1 .. 19); - end if; - end; + return Result (Result'First .. Last); end Image; ------------ diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 5a9f0b24cc3..215a21f505f 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -331,6 +331,13 @@ package body Restrict is return; end if; + -- In formal mode, issue an error for any use of class-wide, even if the + -- No_Dispatch restriction is not set. + + if R = No_Dispatch then + Check_Formal_Restriction ("class-wide is not allowed", N); + end if; + if UI_Is_In_Int_Range (V) then VV := Integer (UI_To_Int (V)); else diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 6e15379b0be..28193ef0ce4 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2375,11 +2375,11 @@ package body Sem_Aggr is -- components of the given type mark. -- b) If the ancestor part is an expression, it must be unambiguous, and - -- once we have its type we can also compute the needed components as in + -- once we have its type we can also compute the needed components as in -- the previous case. In both cases, if the ancestor type is not the -- immediate ancestor, we have to build this ancestor recursively. - -- In both cases discriminants of the ancestor type do not play a role in + -- In both cases, discriminants of the ancestor type do not play a role in -- the resolution of the needed components, because inherited discriminants -- cannot be used in a type extension. As a result we can compute -- independently the list of components of the ancestor type and of the @@ -2483,13 +2483,12 @@ package body Sem_Aggr is Analyze (A); Check_Parameterless_Call (A); - -- In SPARK or ALFA, the ancestor part cannot be a subtype mark + -- In SPARK or ALFA, the ancestor part cannot be a type mark if Is_Entity_Name (A) and then Is_Type (Entity (A)) then - Check_Formal_Restriction - ("ancestor part cannot be a subtype mark", A); + Check_Formal_Restriction ("ancestor part cannot be a type mark", A); end if; if not Is_Tagged_Type (Typ) then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 627e993f4f8..2a8d7c19af3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -17275,89 +17275,108 @@ package body Sem_Ch3 is ("parent of full type must descend from parent" & " of private extension", Full_Indic); - -- Check the rules of 7.3(10): if the private extension inherits - -- known discriminants, then the full type must also inherit those - -- discriminants from the same (ancestor) type, and the parent - -- subtype of the full type must be constrained if and only if - -- the ancestor subtype of the private extension is constrained. - - elsif No (Discriminant_Specifications (Parent (Priv_T))) - and then not Has_Unknown_Discriminants (Priv_T) - and then Has_Discriminants (Base_Type (Priv_Parent)) - then - declare - Priv_Indic : constant Node_Id := - Subtype_Indication (Parent (Priv_T)); + -- First check a formal restriction, and then proceed with checking + -- Ada rules. Since the formal restriction is not a serious error, we + -- don't prevent further error detection for this check, hence the + -- ELSE. - Priv_Constr : constant Boolean := - Is_Constrained (Priv_Parent) - or else - Nkind (Priv_Indic) = N_Subtype_Indication - or else Is_Constrained (Entity (Priv_Indic)); + else - Full_Constr : constant Boolean := - Is_Constrained (Full_Parent) - or else - Nkind (Full_Indic) = N_Subtype_Indication - or else Is_Constrained (Entity (Full_Indic)); + -- In formal mode, when completing a private extension the type + -- named in the private part must be exactly the same as that + -- named in the visible part. - Priv_Discr : Entity_Id; - Full_Discr : Entity_Id; + if Priv_Parent /= Full_Parent then + Error_Msg_Name_1 := Chars (Priv_Parent); + Check_Formal_Restriction ("% expected", Full_Indic); + end if; - begin - Priv_Discr := First_Discriminant (Priv_Parent); - Full_Discr := First_Discriminant (Full_Parent); - while Present (Priv_Discr) and then Present (Full_Discr) loop - if Original_Record_Component (Priv_Discr) = - Original_Record_Component (Full_Discr) - or else - Corresponding_Discriminant (Priv_Discr) = - Corresponding_Discriminant (Full_Discr) - then - null; - else - exit; - end if; + -- Check the rules of 7.3(10): if the private extension inherits + -- known discriminants, then the full type must also inherit those + -- discriminants from the same (ancestor) type, and the parent + -- subtype of the full type must be constrained if and only if + -- the ancestor subtype of the private extension is constrained. - Next_Discriminant (Priv_Discr); - Next_Discriminant (Full_Discr); - end loop; + if No (Discriminant_Specifications (Parent (Priv_T))) + and then not Has_Unknown_Discriminants (Priv_T) + and then Has_Discriminants (Base_Type (Priv_Parent)) + then + declare + Priv_Indic : constant Node_Id := + Subtype_Indication (Parent (Priv_T)); + + Priv_Constr : constant Boolean := + Is_Constrained (Priv_Parent) + or else + Nkind (Priv_Indic) = N_Subtype_Indication + or else + Is_Constrained (Entity (Priv_Indic)); + + Full_Constr : constant Boolean := + Is_Constrained (Full_Parent) + or else + Nkind (Full_Indic) = N_Subtype_Indication + or else + Is_Constrained (Entity (Full_Indic)); + + Priv_Discr : Entity_Id; + Full_Discr : Entity_Id; - if Present (Priv_Discr) or else Present (Full_Discr) then - Error_Msg_N - ("full view must inherit discriminants of the parent type" - & " used in the private extension", Full_Indic); + begin + Priv_Discr := First_Discriminant (Priv_Parent); + Full_Discr := First_Discriminant (Full_Parent); + while Present (Priv_Discr) and then Present (Full_Discr) loop + if Original_Record_Component (Priv_Discr) = + Original_Record_Component (Full_Discr) + or else + Corresponding_Discriminant (Priv_Discr) = + Corresponding_Discriminant (Full_Discr) + then + null; + else + exit; + end if; - elsif Priv_Constr and then not Full_Constr then - Error_Msg_N - ("parent subtype of full type must be constrained", - Full_Indic); + Next_Discriminant (Priv_Discr); + Next_Discriminant (Full_Discr); + end loop; - elsif Full_Constr and then not Priv_Constr then - Error_Msg_N - ("parent subtype of full type must be unconstrained", - Full_Indic); - end if; - end; + if Present (Priv_Discr) or else Present (Full_Discr) then + Error_Msg_N + ("full view must inherit discriminants of the parent" + & " type used in the private extension", Full_Indic); - -- Check the rules of 7.3(12): if a partial view has neither known - -- or unknown discriminants, then the full type declaration shall - -- define a definite subtype. + elsif Priv_Constr and then not Full_Constr then + Error_Msg_N + ("parent subtype of full type must be constrained", + Full_Indic); - elsif not Has_Unknown_Discriminants (Priv_T) - and then not Has_Discriminants (Priv_T) - and then not Is_Constrained (Full_T) - then - Error_Msg_N - ("full view must define a constrained type if partial view" - & " has no discriminants", Full_T); - end if; + elsif Full_Constr and then not Priv_Constr then + Error_Msg_N + ("parent subtype of full type must be unconstrained", + Full_Indic); + end if; + end; + + -- Check the rules of 7.3(12): if a partial view has neither + -- known or unknown discriminants, then the full type + -- declaration shall define a definite subtype. - -- ??????? Do we implement the following properly ????? - -- If the ancestor subtype of a private extension has constrained - -- discriminants, then the parent subtype of the full view shall - -- impose a statically matching constraint on those discriminants - -- [7.3(13)]. + elsif not Has_Unknown_Discriminants (Priv_T) + and then not Has_Discriminants (Priv_T) + and then not Is_Constrained (Full_T) + then + Error_Msg_N + ("full view must define a constrained type if partial view" + & " has no discriminants", Full_T); + end if; + + -- ??????? Do we implement the following properly ????? + -- If the ancestor subtype of a private extension has constrained + -- discriminants, then the parent subtype of the full view shall + -- impose a statically matching constraint on those discriminants + -- [7.3(13)]. + end if; else -- For untagged types, verify that a type without discriminants diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 22234c807b5..00115cc44aa 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5734,6 +5734,22 @@ package body Sem_Res is Check_For_Eliminated_Subprogram (Subp, Nam); end if; + -- In formal mode, the primitive operations of a tagged type or type + -- extension do not include functions that return the tagged type. + + -- Commented out as the call to Is_Inherited_Operation_For_Type may + -- cause an error because the type entity of the parent node of + -- Entity (Name (N) may not be set. + +-- if Nkind (N) = N_Function_Call +-- and then Is_Tagged_Type (Etype (N)) +-- and then Is_Entity_Name (Name (N)) +-- and then Is_Inherited_Operation_For_Type +-- (Entity (Name (N)), Etype (N)) +-- then +-- Check_Formal_Restriction ("function not inherited", N); +-- end if; + -- All done, evaluate call and deal with elaboration issues Eval_Call (N); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 2e0eb7a621f..02f6a6f46f6 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -737,22 +737,12 @@ package body Sem_Type is else raise Program_Error; end if; + end if; - else - BT1 := Base_Type (T1); - BT2 := Base_Type (T2); - - -- Handle underlying view of records with unknown discriminants - -- using the original entity that motivated the construction of - -- this underlying record view (see Build_Derived_Private_Type). - - if Is_Underlying_Record_View (BT1) then - BT1 := Underlying_Record_View (BT1); - end if; + -- Trivial case: same types are always compatible - if Is_Underlying_Record_View (BT2) then - BT2 := Underlying_Record_View (BT2); - end if; + if T1 = T2 then + return True; end if; -- First check for Standard_Void_Type, which is special. Subsequent @@ -762,26 +752,38 @@ package body Sem_Type is if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then return False; + end if; + + BT1 := Base_Type (T1); + BT2 := Base_Type (T2); - -- Simplest case: same types are compatible, and types that have the - -- same base type and are not generic actuals are compatible. Generic - -- actuals belong to their class but are not compatible with other - -- types of their class, and in particular with other generic actuals. - -- They are however compatible with their own subtypes, and itypes - -- with the same base are compatible as well. Similarly, constrained - -- subtypes obtained from expressions of an unconstrained nominal type - -- are compatible with the base type (may lead to spurious ambiguities - -- in obscure cases ???) + -- Handle underlying view of records with unknown discriminants + -- using the original entity that motivated the construction of + -- this underlying record view (see Build_Derived_Private_Type). + + if Is_Underlying_Record_View (BT1) then + BT1 := Underlying_Record_View (BT1); + end if; + + if Is_Underlying_Record_View (BT2) then + BT2 := Underlying_Record_View (BT2); + end if; + + -- Simplest case: types that have the same base type and are not generic + -- actuals are compatible. Generic actuals belong to their class but are + -- not compatible with other types of their class, and in particular + -- with other generic actuals. They are however compatible with their + -- own subtypes, and itypes with the same base are compatible as well. + -- Similarly, constrained subtypes obtained from expressions of an + -- unconstrained nominal type are compatible with the base type (may + -- lead to spurious ambiguities in obscure cases ???) -- Generic actuals require special treatment to avoid spurious ambi- -- guities in an instance, when two formal types are instantiated with -- the same actual, so that different subprograms end up with the same -- signature in the instance. - elsif T1 = T2 then - return True; - - elsif BT1 = BT2 + if BT1 = BT2 or else BT1 = T2 or else BT2 = T1 then @@ -830,7 +832,7 @@ package body Sem_Type is and then Is_Interface (Etype (T1)) and then Is_Concurrent_Type (T2) and then Interface_Present_In_Ancestor - (Typ => Base_Type (T2), + (Typ => BT2, Iface => Etype (T1)) then return True; @@ -889,7 +891,7 @@ package body Sem_Type is elsif Is_Class_Wide_Type (T2) and then (Class_Wide_Type (T1) = T2 - or else Base_Type (Root_Type (T2)) = Base_Type (T1)) + or else Base_Type (Root_Type (T2)) = BT1) then return True; @@ -1037,7 +1039,7 @@ package body Sem_Type is -- The actual type may be the result of a previous error - elsif Base_Type (T2) = Any_Type then + elsif BT2 = Any_Type then return True; -- A packed array type covers its corresponding non-packed type. This is diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 8f285d78e49..91cc8121d60 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6745,6 +6745,18 @@ package body Sem_Util is and then Is_Derived_Type (Etype (E))); end Is_Inherited_Operation; + ------------------------------------- + -- Is_Inherited_Operation_For_Type -- + ------------------------------------- + + function Is_Inherited_Operation_For_Type + (E, Typ : Entity_Id) return Boolean + is + begin + return Is_Inherited_Operation (E) + and then Etype (Parent (E)) = Typ; + end Is_Inherited_Operation_For_Type; + ----------------------------- -- Is_Library_Level_Entity -- ----------------------------- @@ -6845,27 +6857,6 @@ package body Sem_Util is end if; end Is_Object_Reference; - ------------------------------- - -- Is_SPARK_Object_Reference -- - ------------------------------- - - function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is - begin - if Is_Entity_Name (N) then - return Present (Entity (N)) - and then - (Ekind_In (Entity (N), E_Constant, E_Variable) - or else Ekind (Entity (N)) in Formal_Kind); - - else - if Nkind (N) = N_Selected_Component then - return Is_SPARK_Object_Reference (Prefix (N)); - else - return False; - end if; - end if; - end Is_SPARK_Object_Reference; - ----------------------------------- -- Is_OK_Variable_For_Out_Formal -- ----------------------------------- @@ -7377,6 +7368,29 @@ package body Sem_Util is end if; end Is_Selector_Name; + ------------------------------- + -- Is_SPARK_Object_Reference -- + ------------------------------- + + function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is + begin + if Is_Entity_Name (N) then + return Present (Entity (N)) + and then + (Ekind_In (Entity (N), E_Constant, E_Variable) + or else Ekind (Entity (N)) in Formal_Kind); + + else + case Nkind (N) is + when N_Selected_Component => + return Is_SPARK_Object_Reference (Prefix (N)); + + when others => + return False; + end case; + end if; + end Is_SPARK_Object_Reference; + ------------------ -- Is_Statement -- ------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 6625d3fc878..715fc1b0499 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -748,7 +748,12 @@ package Sem_Util is function Is_Inherited_Operation (E : Entity_Id) return Boolean; -- E is a subprogram. Return True is E is an implicit operation inherited - -- by a derived type declarations. + -- by a derived type declaration. + + function Is_Inherited_Operation_For_Type + (E, Typ : Entity_Id) return Boolean; + -- E is a subprogram. Return True is E is an implicit operation inherited + -- by the derived type declaration for type Typ. function Is_LHS (N : Node_Id) return Boolean; -- Returns True iff N is used as Name in an assignment statement @@ -766,9 +771,6 @@ package Sem_Util is -- Determines if the tree referenced by N represents an object. Both -- variable and constant objects return True (compare Is_Variable). - function Is_SPARK_Object_Reference (N : Node_Id) return Boolean; - -- Determines if the tree referenced by N represents an object in SPARK - function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean; -- Used to test if AV is an acceptable formal for an OUT or IN OUT formal. -- Note that the Is_Variable function is not quite the right test because @@ -826,6 +828,9 @@ package Sem_Util is -- represent use of the N_Identifier node for a true identifier, when -- normally such nodes represent a direct name. + function Is_SPARK_Object_Reference (N : Node_Id) return Boolean; + -- Determines if the tree referenced by N represents an object in SPARK + function Is_Statement (N : Node_Id) return Boolean; pragma Inline (Is_Statement); -- Check if the node N is a statement node. Note that this includes