+2014-08-04 Robert Dewar <dewar@adacore.com>
+
+ * inline.adb, einfo.ads, s-tassta.adb, s-tarest.adb: Minor comment
+ fixes.
+
+2014-08-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Process_Import_Or_Interface): Handle properly
+ an aspect Import that specifies a False value.
+
+2014-08-04 Robert Dewar <dewar@adacore.com>
+
+ * gnat_rm.texi: Add section on aspect Invariant'Class.
+
+2014-08-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_case.adb (Check_Choice_Set): New flag Predicate_Error,
+ for better control of cascaded error messages when some choice
+ in a case statement over a predicated type violates the given
+ static predicate.
+
+2014-08-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb (Build_Derived_Type): Modify the
+ inheritance of the rep chain to ensure that a non-tagged type's
+ items are not clobbered during the inheritance.
+
2014-08-04 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, einfo.ads: Minor reformatting.
-- Requires_Overriding (Flag213) (non-generic case only)
-- Return_Present (Flag54)
-- Returns_By_Ref (Flag90)
- -- Returns_Limited_View (Flag134)
+ -- Returns_Limited_View (Flag134) (non-generic case only)
-- Sec_Stack_Needed_For_Return (Flag167)
-- SPARK_Pragma_Inherited (Flag265)
-- Uses_Sec_Stack (Flag95)
* Aspect Initializes::
* Aspect Inline_Always::
* Aspect Invariant::
+* Aspect Invariant'Class::
* Aspect Iterable::
* Aspect Linker_Section::
* Aspect No_Elaboration_Code_All::
* Aspect Initializes::
* Aspect Inline_Always::
* Aspect Invariant::
+* Aspect Invariant'Class::
* Aspect Iterable::
* Aspect Linker_Section::
* Aspect Lock_Free::
synonym for the language defined aspect @code{Type_Invariant} except
that it is separately controllable using pragma @code{Assertion_Policy}.
+@node Aspect Invariant'Class
+@unnumberedsec Aspect Invariant'Class
+@findex Invariant'Class
+@noindent
+This aspect is equivalent to pragma @code{Type_Invariant_Class}. It is a
+synonym for the language defined aspect @code{Type_Invariant'Class} except
+that it is separately controllable using pragma @code{Assertion_Policy}.
+
@node Aspect Iterable
@unnumberedsec Aspect Iterable
@findex Iterable
function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
-- Returns True if subprogram Id defines a compilation unit
+ -- Shouldn't this be in Sem_Aux???
function In_Package_Visible_Spec (Id : Node_Id) return Boolean;
-- Returns True if subprogram Id is defined in the visible part of a
(1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100);
for Secondary_Stack'Alignment use Standard'Maximum_Alignment;
+ -- This is the secondary stack data. Note that it is critical that this
+ -- have maximum alignment, since any kind of data can be allocated here.
pragma Warnings (Off);
Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size);
for Secondary_Stack'Alignment use Standard'Maximum_Alignment;
- -- Actual area allocated for secondary stack
+ -- Actual area allocated for secondary stack. Note that it is critical
+ -- that this have maximum alignment, since any kind of data can be
+ -- allocated here.
Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
-- Address of secondary stack. In the fixed secondary stack case, this
Subtyp : Entity_Id;
Others_Present : Boolean;
Case_Node : Node_Id)
+
is
+ Predicate_Error : Boolean;
+ -- Flag to prevent cascaded errors when a static predicate is known to
+ -- be violated by one choice.
+
procedure Check_Against_Predicate
(Pred : in out Node_Id;
Choice : Choice_Bounds;
elsif Value1 > Value2 then
return;
+
+ -- If predicate is already known to be violated, do no check for
+ -- coverage error, to prevent cascaded messages.
+
+ elsif Predicate_Error then
+ return;
end if;
-- Case of only one value that is missing
-- expression is static, independently of whether the aspect mentions
-- Static explicitly.
+ Predicate_Error := False;
+
if Has_Predicate then
Pred := First (Static_Discrete_Predicate (Bounds_Type));
Prev_Lo := Uint_Minus_1;
Error => Error);
-- The analysis detected an illegal intersection between a choice
- -- and a static predicate set.
+ -- and a static predicate set. Do not examine other choices unless
+ -- all errors are requested.
if Error then
- return;
+ Predicate_Error := True;
+ if not All_Errors_Mode then
+ return;
+ end if;
end if;
end loop;
+ if Predicate_Error then
+ return;
+ end if;
+
-- The choices may legally cover some of the static predicate sets,
-- but not all. Emit an error for each non-covered set.
-- The derived type inherits the representation clauses of the parent.
-- However, for a private type that is completed by a derivation, there
-- may be operation attributes that have been specified already (stream
- -- attributes and External_Tag) and those must be provided. Finally,
- -- if the partial view is a private extension, the representation items
- -- of the parent have been inherited already, and should not be chained
+ -- attributes and External_Tag) and those must be provided. Finally, if
+ -- the partial view is a private extension, the representation items of
+ -- the parent have been inherited already, and should not be chained
-- twice to the derived type.
- if Is_Tagged_Type (Parent_Type)
- and then Present (First_Rep_Item (Derived_Type))
- then
- -- The existing items are either operational items or items inherited
- -- from a private extension declaration.
+ -- Historic note: The guard below used to check whether the parent type
+ -- is tagged. This is no longer needed because an untagged derived type
+ -- may carry rep items of its own as a result of certain SPARK pragmas.
+ -- With the old guard in place, the rep items of the derived type were
+ -- clobbered.
+ if Present (First_Rep_Item (Derived_Type)) then
declare
- Rep : Node_Id;
- -- Used to iterate over representation items of the derived type
-
- Last_Rep : Node_Id;
- -- Last representation item of the (non-empty) representation
- -- item list of the derived type.
-
- Found : Boolean := False;
+ Par_Item : constant Node_Id := First_Rep_Item (Parent_Type);
+ Inherited : Boolean := False;
+ Item : Node_Id;
+ Last_Item : Node_Id;
begin
- Rep := First_Rep_Item (Derived_Type);
- Last_Rep := Rep;
- while Present (Rep) loop
- if Rep = First_Rep_Item (Parent_Type) then
- Found := True;
+ -- Inspect the rep item chain of the derived type and perform the
+ -- following two functions:
+ -- 1) Determine whether the derived type already inherited the
+ -- rep items of the parent type.
+ -- 2) Find the last rep item of the derived type
+
+ Item := First_Rep_Item (Derived_Type);
+ Last_Item := Item;
+ while Present (Item) loop
+ if Item = Par_Item then
+ Inherited := True;
exit;
-
- else
- Rep := Next_Rep_Item (Rep);
-
- if Present (Rep) then
- Last_Rep := Rep;
- end if;
end if;
+
+ Last_Item := Item;
+ Item := Next_Rep_Item (Item);
end loop;
- -- Here if we either encountered the parent type's first rep
- -- item on the derived type's rep item list (in which case
- -- Found is True, and we have nothing else to do), or if we
- -- reached the last rep item of the derived type, which is
- -- Last_Rep, in which case we further chain the parent type's
- -- rep items to those of the derived type.
+ -- Nothing to do if the derived type already inherited the rep
+ -- items from the parent type, otherwise append the parent rep
+ -- item chain to that of the derived type.
- if not Found then
- Set_Next_Rep_Item (Last_Rep, First_Rep_Item (Parent_Type));
+ if not Inherited then
+ Set_Next_Rep_Item (Last_Item, Par_Item);
end if;
end;
+ -- Otherwise the derived type lacks rep items and directly inherits the
+ -- rep items of the parent type.
+
else
Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
end if;
end if;
end;
- Set_Has_Completion (Def_Id);
+ -- If the pragma comes from an aspect specification, there
+ -- must be an Import aspect specified as well. In the rare
+ -- case where Import is set to False, the suprogram needs to
+ -- have a local completion.
+
+ declare
+ Imp_Aspect : constant Node_Id :=
+ Find_Aspect (Def_Id, Aspect_Import);
+ Expr : Node_Id;
+
+ begin
+ if Present (Imp_Aspect)
+ and then Present (Expression (Imp_Aspect))
+ then
+ Expr := Expression (Imp_Aspect);
+ Analyze_And_Resolve (Expr, Standard_Boolean);
+
+ if Is_Entity_Name (Expr)
+ and then Entity (Expr) = Standard_True
+ then
+ Set_Has_Completion (Def_Id);
+ end if;
+
+ -- If there is no expression, the default is True, as for
+ -- all boolean aspects. Same for the older pragma.
+
+ else
+ Set_Has_Completion (Def_Id);
+ end if;
+ end;
+
Process_Interface_Name (Def_Id, Arg3, Arg4);
end if;
projects / thirdparty / gcc.git / commitdiff
