[multiple changes]
2011-08-02 Geert Bosch <bosch@adacore.com> * a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image. 2011-08-02 Eric Botcazou <ebotcazou@adacore.com> * sem_type.adb (Covers): Move trivial case to the top and reuse the computed value of Base_Type. 2011-08-02 Yannick Moy <moy@adacore.com> * 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
This commit is contained in:
parent
fb86fe11bf
commit
12f0c50ca9
|
@ -1,3 +1,29 @@
|
|||
2011-08-02 Geert Bosch <bosch@adacore.com>
|
||||
|
||||
* a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image.
|
||||
|
||||
2011-08-02 Eric Botcazou <ebotcazou@adacore.com>
|
||||
|
||||
* sem_type.adb (Covers): Move trivial case to the top and reuse the
|
||||
computed value of Base_Type.
|
||||
|
||||
2011-08-02 Yannick Moy <moy@adacore.com>
|
||||
|
||||
* 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 <schonberg@adacore.com>
|
||||
|
||||
* sem_ch5.adb (Pre_Analyze_Range): new procedure extracted from
|
||||
|
|
|
@ -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;
|
||||
-- Second processing, positions 8 and 9
|
||||
|
||||
Result (8) := To_Char (Second / 10);
|
||||
Result (9) := To_Char (Second mod 10);
|
||||
|
||||
-- Optional sub second processing, positions 11 and 12
|
||||
|
||||
if Include_Time_Fraction and then Sub_Second > 0.0 then
|
||||
|
||||
-- Prevent rounding up when converting to natural, avoiding the zero
|
||||
-- case to prevent rounding down to a negative number.
|
||||
|
||||
SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5);
|
||||
|
||||
Result (11) := To_Char (SS_Nat / 10);
|
||||
Result (12) := To_Char (SS_Nat mod 10);
|
||||
end if;
|
||||
|
||||
SS_Nat := Natural (Sub_Second);
|
||||
|
||||
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);
|
||||
|
||||
begin
|
||||
-- Hour processing, positions 2 and 3
|
||||
|
||||
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
|
||||
|
||||
if Minute < 10 then
|
||||
Result (6) := Minute_Str (2);
|
||||
else
|
||||
Result (5) := Minute_Str (2);
|
||||
Result (6) := Minute_Str (3);
|
||||
end if;
|
||||
|
||||
-- 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;
|
||||
|
||||
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
|
||||
-- Year processing, positions 1, 2, 3 and 4
|
||||
|
||||
Sub_Second := Sub_Second * 100.0;
|
||||
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);
|
||||
|
||||
if Sub_Second > 0.0 then
|
||||
Sub_Second := Sub_Second - 0.5;
|
||||
-- Month processing, positions 6 and 7
|
||||
|
||||
Result (6) := To_Char (Month / 10);
|
||||
Result (7) := To_Char (Month mod 10);
|
||||
|
||||
-- Day processing, positions 9 and 10
|
||||
|
||||
Result (9) := To_Char (Day / 10);
|
||||
Result (10) := To_Char (Day mod 10);
|
||||
|
||||
Result (12) := To_Char (Hour / 10);
|
||||
Result (13) := To_Char (Hour mod 10);
|
||||
|
||||
-- Minute processing, positions 15 and 16
|
||||
|
||||
Result (15) := To_Char (Minute / 10);
|
||||
Result (16) := To_Char (Minute mod 10);
|
||||
|
||||
-- Second processing, positions 18 and 19
|
||||
|
||||
Result (18) := To_Char (Second / 10);
|
||||
Result (19) := To_Char (Second mod 10);
|
||||
|
||||
-- Optional sub second processing, positions 21 and 22
|
||||
|
||||
if Include_Time_Fraction and then Sub_Second > 0.0 then
|
||||
|
||||
-- Prevent rounding up when converting to natural, avoiding the zero
|
||||
-- case to prevent rounding down to a negative number.
|
||||
|
||||
SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5);
|
||||
|
||||
Result (21) := To_Char (SS_Nat / 10);
|
||||
Result (22) := To_Char (SS_Nat mod 10);
|
||||
end if;
|
||||
|
||||
SS_Nat := Natural (Sub_Second);
|
||||
|
||||
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);
|
||||
|
||||
begin
|
||||
-- Year processing, positions 1, 2, 3 and 4
|
||||
|
||||
Result (1) := Year_Str (2);
|
||||
Result (2) := Year_Str (3);
|
||||
Result (3) := Year_Str (4);
|
||||
Result (4) := Year_Str (5);
|
||||
|
||||
-- Month processing, positions 6 and 7
|
||||
|
||||
if Month < 10 then
|
||||
Result (7) := Month_Str (2);
|
||||
else
|
||||
Result (6) := Month_Str (2);
|
||||
Result (7) := Month_Str (3);
|
||||
end if;
|
||||
|
||||
-- Day processing, positions 9 and 10
|
||||
|
||||
if Day < 10 then
|
||||
Result (10) := Day_Str (2);
|
||||
else
|
||||
Result (9) := Day_Str (2);
|
||||
Result (10) := Day_Str (3);
|
||||
end if;
|
||||
|
||||
-- Hour processing, positions 12 and 13
|
||||
|
||||
if Hour < 10 then
|
||||
Result (13) := Hour_Str (2);
|
||||
else
|
||||
Result (12) := Hour_Str (2);
|
||||
Result (13) := Hour_Str (3);
|
||||
end if;
|
||||
|
||||
-- Minute processing, positions 15 and 16
|
||||
|
||||
if Minute < 10 then
|
||||
Result (16) := Minute_Str (2);
|
||||
else
|
||||
Result (15) := Minute_Str (2);
|
||||
Result (16) := Minute_Str (3);
|
||||
end if;
|
||||
|
||||
-- Second processing, positions 18 and 19
|
||||
|
||||
if Second < 10 then
|
||||
Result (19) := Second_Str (2);
|
||||
else
|
||||
Result (18) := Second_Str (2);
|
||||
Result (19) := Second_Str (3);
|
||||
end if;
|
||||
|
||||
-- Optional sub second processing, positions 21 and 22
|
||||
|
||||
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;
|
||||
|
||||
return Result;
|
||||
else
|
||||
return Result (1 .. 19);
|
||||
end if;
|
||||
end;
|
||||
return Result (Result'First .. Last);
|
||||
end Image;
|
||||
|
||||
------------
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -17275,90 +17275,109 @@ 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.
|
||||
-- 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.
|
||||
|
||||
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));
|
||||
else
|
||||
|
||||
Priv_Constr : constant Boolean :=
|
||||
Is_Constrained (Priv_Parent)
|
||||
or else
|
||||
Nkind (Priv_Indic) = N_Subtype_Indication
|
||||
or else Is_Constrained (Entity (Priv_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.
|
||||
|
||||
Full_Constr : constant Boolean :=
|
||||
Is_Constrained (Full_Parent)
|
||||
or else
|
||||
Nkind (Full_Indic) = N_Subtype_Indication
|
||||
or else Is_Constrained (Entity (Full_Indic));
|
||||
if Priv_Parent /= Full_Parent then
|
||||
Error_Msg_Name_1 := Chars (Priv_Parent);
|
||||
Check_Formal_Restriction ("% expected", Full_Indic);
|
||||
end if;
|
||||
|
||||
Priv_Discr : Entity_Id;
|
||||
Full_Discr : Entity_Id;
|
||||
-- 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.
|
||||
|
||||
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;
|
||||
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;
|
||||
|
||||
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;
|
||||
|
||||
Next_Discriminant (Priv_Discr);
|
||||
Next_Discriminant (Full_Discr);
|
||||
end loop;
|
||||
|
||||
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);
|
||||
|
||||
elsif Priv_Constr and then not Full_Constr then
|
||||
Error_Msg_N
|
||||
("parent subtype of full type must be constrained",
|
||||
Full_Indic);
|
||||
|
||||
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;
|
||||
|
||||
Next_Discriminant (Priv_Discr);
|
||||
Next_Discriminant (Full_Discr);
|
||||
end loop;
|
||||
-- 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.
|
||||
|
||||
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);
|
||||
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 Priv_Constr and then not Full_Constr then
|
||||
Error_Msg_N
|
||||
("parent subtype of full type must be constrained",
|
||||
Full_Indic);
|
||||
|
||||
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.
|
||||
|
||||
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);
|
||||
-- ??????? 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;
|
||||
|
||||
-- ??????? 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)].
|
||||
|
||||
else
|
||||
-- For untagged types, verify that a type without discriminants
|
||||
-- is not completed with an unconstrained type.
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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);
|
||||
-- Trivial case: same types are always compatible
|
||||
|
||||
-- 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;
|
||||
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;
|
||||
|
||||
-- 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 ???)
|
||||
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;
|
||||
|
||||
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
|
||||
|
|
|
@ -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 --
|
||||
------------------
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue