+2017-04-25 Yannick Moy <moy@adacore.com>
+
+ * freeze.adb (Freeze_Record_Type): Remove obsolete
+ rule on volatile tagged record restriction on SPARK code.
+
+2017-04-25 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb (minor) Fix SPARK RM reference.
+
+2017-04-25 Yannick Moy <moy@adacore.com>
+
+ * sem_util.adb, sem_util.ads (Unique_Defining_Entity): Update
+ comment to reflect which entity is chosen as unique entity.
+ (Unique_Entity): Return full view instead of private spec for
+ protected type or task type. Fix possible incorrect access when
+ called on entry.
+
+2017-04-25 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_res.adb (Set_Slice_Subtype): Treat specially bit-packed
+ array types only instead of all packed array types.
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Conforming_Types): If type of formal as a specified
+ dimension system, verify that dimensions of both match.
+ (Check_Conformance): Add error message in case of dimension
+ mismatch.
+ * sem_dim.ads, sem_dim.adb (Dimensions_Match): New utility
+ predicate.
+
+2017-04-25 Arnaud Charlet <charlet@adacore.com trojanek>
+
+ * gnatxref.adb, gnatfind.adb: Avoid using the term project file,
+ confusing.
+
2017-04-25 Yannick Moy <moy@adacore.com>
* sem_util.adb: Minor refactoring.
-- they are not standard Ada legality rules.
if SPARK_Mode = On then
- if Is_Effectively_Volatile (Rec) then
- -- A discriminated type cannot be effectively volatile
- -- (SPARK RM 7.1.3(5)).
+ -- A discriminated type cannot be effectively volatile
+ -- (SPARK RM 7.1.3(5)).
- if Has_Discriminants (Rec)
- and then not Is_Protected_Type (Rec)
- then
+ if Is_Effectively_Volatile (Rec) then
+ if Has_Discriminants (Rec) then
Error_Msg_N ("discriminated type & cannot be volatile", Rec);
-
- -- A tagged type cannot be effectively volatile
- -- (SPARK RM C.6(5)).
-
- elsif Is_Tagged_Type (Rec) then
- Error_Msg_N ("tagged type & cannot be volatile", Rec);
end if;
-- A non-effectively volatile record type cannot contain
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Put_Line (" --ext=xxx Specify alternate ali file extension");
Put_Line (" --RTS=dir specify the default source and object search"
& " path");
- Put_Line (" -p file Use file as the default project file");
+ Put_Line (" -p file Use file as the configuration file");
Put_Line (" -r Find all references (default to find declaration"
& " only)");
Put_Line (" -s Print source line");
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Put_Line (" --ext=xxx Specify alternate ali file extension");
Put_Line (" --RTS=dir specify the default source and object search"
& " path");
- Put_Line (" -p file Use file as the default project file");
+ Put_Line (" -p file Use file as the configuration file");
Put_Line (" -u List unused entities");
Put_Line (" -v Print a 'tags' file for vi");
New_Line;
else
Conformance_Error
("\type of & does not match!", New_Formal);
+
+ if not Dimensions_Match (Old_Formal_Base, New_Formal_Base)
+ then
+ Error_Msg_N ("\dimensions mismatch!", New_Formal);
+ end if;
end if;
end if;
return True;
elsif Base_Types_Match (Type_1, Type_2) then
- return Ctype <= Mode_Conformant
- or else Subtypes_Statically_Match (Type_1, Type_2);
+ if Ctype <= Mode_Conformant then
+ return True;
+
+ else
+ return
+ Subtypes_Statically_Match (Type_1, Type_2)
+ and then Dimensions_Match (Type_1, Type_2);
+ end if;
elsif Is_Incomplete_Or_Private_Type (Type_1)
and then Present (Full_View (Type_1))
and then Base_Types_Match (Full_View (Type_1), Type_2)
then
- return Ctype <= Mode_Conformant
- or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
+ return
+ Ctype <= Mode_Conformant
+ or else Subtypes_Statically_Match (Full_View (Type_1), Type_2);
elsif Ekind (Type_2) = E_Incomplete_Type
and then Present (Full_View (Type_2))
and then Base_Types_Match (Type_1, Full_View (Type_2))
then
- return Ctype <= Mode_Conformant
- or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
+ return
+ Ctype <= Mode_Conformant
+ or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
elsif Is_Private_Type (Type_2)
and then In_Instance
and then Present (Full_View (Type_2))
and then Base_Types_Match (Type_1, Full_View (Type_2))
then
- return Ctype <= Mode_Conformant
- or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
+ return
+ Ctype <= Mode_Conformant
+ or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
-- Another confusion between views in a nested instance with an
-- actual private type whose full view is not in scope.
elsif Are_Anonymous_Access_To_Subprogram_Types then
if Ada_Version < Ada_2005 then
- return Ctype = Type_Conformant
- or else
- Subtypes_Statically_Match (Desig_1, Desig_2);
+ return
+ Ctype = Type_Conformant
+ or else Subtypes_Statically_Match (Desig_1, Desig_2);
-- We must check the conformance of the signatures themselves
-- Copy_Dimensions --
---------------------
- procedure Copy_Dimensions (From, To : Node_Id) is
+ procedure Copy_Dimensions (From : Node_Id; To : Node_Id) is
Dims_Of_From : constant Dimension_Type := Dimensions_Of (From);
begin
Error_Msg_N ("assumed to be%%??", N);
end Dim_Warning_For_Numeric_Literal;
+ ----------------------
+ -- Dimensions_Match --
+ ----------------------
+
+ function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
+ begin
+ return
+ not Has_Dimension_System (Base_Type (T1))
+ or else Dimensions_Of (T1) = Dimensions_Of (T2);
+ end Dimensions_Match;
+
----------------------------------------
-- Eval_Op_Expon_For_Dimensioned_Type --
----------------------------------------
-- resolution of the ultimate components to a separate phase, which forces
-- this separate dimension verification.
- procedure Copy_Dimensions (From, To : Node_Id);
+ procedure Copy_Dimensions (From : Node_Id; To : Node_Id);
-- Copy dimension vector of node From to node To. Note that To must be a
-- node that is allowed to contain a dimension (see OK_For_Dimension in
-- body of Sem_Dim).
+ function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
+ -- If the common base type has a dimension system, verify that two
+ -- subtypes have the same dimensions. Used for conformance checking.
+
procedure Eval_Op_Expon_For_Dimensioned_Type
(N : Node_Id;
Btyp : Entity_Id);
-- The following check is only relevant when SPARK_Mode is on as
-- this is not a standard Ada legality rule. Pragma Volatile can
-- only apply to a full type declaration or an object declaration
- -- (SPARK RM C.6(1)). Original_Node is necessary to account for
+ -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
-- untagged derived types that are rewritten as subtypes of their
-- respective root types.
Set_Etype (N, Slice_Subtype);
- -- For packed slice subtypes, freeze immediately (except in the case of
- -- being in a "spec expression" where we never freeze when we first see
- -- the expression).
+ -- For bit-packed slice subtypes, freeze immediately (except in the case
+ -- of being in a "spec expression" where we never freeze when we first
+ -- see the expression).
- if Is_Packed (Slice_Subtype) and not In_Spec_Expression then
+ if Is_Bit_Packed_Array (Slice_Subtype) and not In_Spec_Expression then
Freeze_Itype (Slice_Subtype, N);
-- For all other cases insert an itype reference in the slice's actions
Prot_Type := Scope (Scope (E));
end if;
- pragma Assert (Ekind (Prot_Type) = E_Protected_Type);
+ -- A protected type may be declared as a private type, in
+ -- which case we need to get its full view.
- -- Traverse the entity list of the protected type and locate
- -- an entry declaration which matches the entry body.
+ if Is_Private_Type (Prot_Type) then
+ Prot_Type := Full_View (Prot_Type);
+ end if;
- Prot_Item := First_Entity (Prot_Type);
- while Present (Prot_Item) loop
- if Ekind (Prot_Item) in Entry_Kind
- and then Corresponding_Body (Parent (Prot_Item)) = E
- then
- U := Prot_Item;
- exit;
- end if;
+ -- Full view may not be present on error, in which case
+ -- return E by default.
- Next_Entity (Prot_Item);
- end loop;
+ if Present (Prot_Type) then
+ pragma Assert (Ekind (Prot_Type) = E_Protected_Type);
+
+ -- Traverse the entity list of the protected type and
+ -- locate an entry declaration which matches the entry
+ -- body.
+
+ Prot_Item := First_Entity (Prot_Type);
+ while Present (Prot_Item) loop
+ if Ekind (Prot_Item) in Entry_Kind
+ and then Corresponding_Body (Parent (Prot_Item)) = E
+ then
+ U := Prot_Item;
+ exit;
+ end if;
+
+ Next_Entity (Prot_Item);
+ end loop;
+ end if;
end;
end if;
end if;
end if;
+ if Is_Private_Type (U) then
+ U := Full_View (U);
+ end if;
+
when E_Subprogram_Body =>
P := Parent (E);
end if;
end if;
+ if Is_Private_Type (U) then
+ U := Full_View (U);
+ end if;
+
when Type_Kind =>
if Present (Full_View (E)) then
U := Full_View (E);
function Unique_Defining_Entity (N : Node_Id) return Entity_Id;
-- Return the entity which represents declaration N, so that different
-- views of the same entity have the same unique defining entity:
- -- * entry declaration and entry body
- -- * package spec, package body, and package body stub
- -- * protected type declaration, protected body, and protected body stub
-- * private view and full view of a deferred constant
- -- * private view and full view of a type
- -- * subprogram declaration, subprogram, and subprogram body stub
- -- * task type declaration, task body, and task body stub
+ -- --> full view
+ -- * entry spec and entry body
+ -- --> entry spec
+ -- * formal parameter on spec and body
+ -- --> formal parameter on spec
+ -- * package spec, body, and body stub
+ -- --> package spec
+ -- * protected type, protected body, and protected body stub
+ -- --> protected type (full view if private)
+ -- * subprogram spec, body, and body stub
+ -- --> subprogram spec
+ -- * task type, task body, and task body stub
+ -- --> task type (full view if private)
+ -- * private or incomplete view and full view of a type
+ -- --> full view
-- In other cases, return the defining entity for N.
function Unique_Entity (E : Entity_Id) return Entity_Id;
projects / gcc.git / commitdiff