+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
(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;
-----------
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;
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;
------------
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
-- 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
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
("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
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);
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
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
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;
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;
-- 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
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 --
-----------------------------
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 --
-----------------------------------
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 --
------------------
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
-- 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
-- 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
projects / gcc.git / commitdiff