[multiple changes]
2011-11-21 Robert Dewar <dewar@adacore.com> * sinput.ads: Minor comment fix. 2011-11-21 Robert Dewar <dewar@adacore.com> * exp_attr.adb (Expand_N_Attribute_Reference, case First_Bit, Last_Bit, Position): Handle 2005 case. 2011-11-21 Robert Dewar <dewar@adacore.com> * s-atocou-builtin.adb (Decrement): Use Unrestricted_Access to deal with fact that we properly detect the error if Access is used. (Increment): Same fix. * s-taprop-linux.adb (Create_Task): Use Unrestricted_Access to deal with fact that we properly detect the error if Access is used. * sem_util.adb (Is_Volatile_Object): Properly record that A.B is volatile if the B component is volatile. This affects the check for passing such a by reference volatile actual to a non-volatile formal (which should be illegal) 2011-11-21 Robert Dewar <dewar@adacore.com> * freeze.adb (Freeze_Enumeration_Type): Make sure to set both size and alignment for foreign convention enumeration types. * layout.adb (Set_Elem_Alignment): Redo setting of alignment when size is set. 2011-11-21 Yannick Moy <moy@adacore.com> * checks.adb (Apply_Access_Check, Apply_Arithmetic_Overflow_Check, Apply_Discriminant_Check, Apply_Divide_Check, Apply_Selected_Length_Checks, Apply_Selected_Range_Checks, Build_Discriminant_Checks, Insert_Range_Checks, Selected_Length_Checks, Selected_Range_Checks): Replace reference to Expander_Active with reference to Full_Expander_Active, so that expansion of checks is not performed in Alfa mode 2011-11-21 Tristan Gingold <gingold@adacore.com> * s-taprop-vms.adb (Create_Task): Use Unrestricted_Access to deal with fact that we properly detect the error if Access is used. 2011-11-21 Hristian Kirtchev <kirtchev@adacore.com> * par-ch4.adb (P_Quantified_Expression): Add an Ada 2012 check. 2011-11-21 Hristian Kirtchev <kirtchev@adacore.com> * exp_imgv.adb: Add with and use clause for Errout. (Expand_Width_Attribute): Emit a warning when in configurable run-time mode to provide a better diagnostic message. 2011-11-21 Hristian Kirtchev <kirtchev@adacore.com> * s-finmas.adb (Finalize): Add comment concerning double finalization. 2011-11-21 Ed Schonberg <schonberg@adacore.com> * sem_ch3.adb (Access_Definition): If the access definition is itself the return type of an access to function definition which is ultimately the return type of an access to subprogram declaration, its scope is the enclosing scope of the ultimate access to subprogram. 2011-11-21 Steve Baird <baird@adacore.com> * sem_res.adb (Valid_Conversion): If a conversion was legal in the body of a generic, then the corresponding conversion is legal in the expanded body of an instance of the generic. From-SVN: r181568
This commit is contained in:
parent
8e0aa19b43
commit
be482a8c83
|
@ -1,3 +1,76 @@
|
||||||
|
2011-11-21 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* sinput.ads: Minor comment fix.
|
||||||
|
|
||||||
|
2011-11-21 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* exp_attr.adb (Expand_N_Attribute_Reference, case First_Bit,
|
||||||
|
Last_Bit, Position): Handle 2005 case.
|
||||||
|
|
||||||
|
2011-11-21 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* s-atocou-builtin.adb (Decrement): Use Unrestricted_Access
|
||||||
|
to deal with fact that we properly detect the error if Access
|
||||||
|
is used.
|
||||||
|
(Increment): Same fix.
|
||||||
|
* s-taprop-linux.adb (Create_Task): Use Unrestricted_Access
|
||||||
|
to deal with fact that we properly detect the error if Access
|
||||||
|
is used.
|
||||||
|
* sem_util.adb (Is_Volatile_Object): Properly record that A.B is
|
||||||
|
volatile if the B component is volatile. This affects the check
|
||||||
|
for passing such a by reference volatile actual to a non-volatile
|
||||||
|
formal (which should be illegal)
|
||||||
|
|
||||||
|
2011-11-21 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* freeze.adb (Freeze_Enumeration_Type): Make sure to set both
|
||||||
|
size and alignment for foreign convention enumeration types.
|
||||||
|
* layout.adb (Set_Elem_Alignment): Redo setting of alignment
|
||||||
|
when size is set.
|
||||||
|
|
||||||
|
2011-11-21 Yannick Moy <moy@adacore.com>
|
||||||
|
|
||||||
|
* checks.adb (Apply_Access_Check, Apply_Arithmetic_Overflow_Check,
|
||||||
|
Apply_Discriminant_Check, Apply_Divide_Check,
|
||||||
|
Apply_Selected_Length_Checks, Apply_Selected_Range_Checks,
|
||||||
|
Build_Discriminant_Checks, Insert_Range_Checks, Selected_Length_Checks,
|
||||||
|
Selected_Range_Checks): Replace reference to Expander_Active
|
||||||
|
with reference to Full_Expander_Active, so that expansion of
|
||||||
|
checks is not performed in Alfa mode
|
||||||
|
|
||||||
|
2011-11-21 Tristan Gingold <gingold@adacore.com>
|
||||||
|
|
||||||
|
* s-taprop-vms.adb (Create_Task): Use Unrestricted_Access to deal with
|
||||||
|
fact that we properly detect the error if Access is used.
|
||||||
|
|
||||||
|
2011-11-21 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
|
* par-ch4.adb (P_Quantified_Expression): Add an Ada 2012 check.
|
||||||
|
|
||||||
|
2011-11-21 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
|
* exp_imgv.adb: Add with and use clause for Errout.
|
||||||
|
(Expand_Width_Attribute): Emit a warning when in
|
||||||
|
configurable run-time mode to provide a better diagnostic message.
|
||||||
|
|
||||||
|
2011-11-21 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
|
* s-finmas.adb (Finalize): Add comment concerning double finalization.
|
||||||
|
|
||||||
|
2011-11-21 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
|
* sem_ch3.adb (Access_Definition): If the access definition
|
||||||
|
is itself the return type of an access to function definition
|
||||||
|
which is ultimately the return type of an access to subprogram
|
||||||
|
declaration, its scope is the enclosing scope of the ultimate
|
||||||
|
access to subprogram.
|
||||||
|
|
||||||
|
2011-11-21 Steve Baird <baird@adacore.com>
|
||||||
|
|
||||||
|
* sem_res.adb (Valid_Conversion): If a conversion was legal
|
||||||
|
in the body of a generic, then the corresponding conversion is
|
||||||
|
legal in the expanded body of an instance of the generic.
|
||||||
|
|
||||||
2011-11-21 Robert Dewar <dewar@adacore.com>
|
2011-11-21 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
* sem_ch3.adb: Minor reformatting.
|
* sem_ch3.adb: Minor reformatting.
|
||||||
|
|
|
@ -442,7 +442,7 @@ package body Checks is
|
||||||
-- are cases (e.g. with pragma Debug) where generating the checks
|
-- are cases (e.g. with pragma Debug) where generating the checks
|
||||||
-- can cause real trouble).
|
-- can cause real trouble).
|
||||||
|
|
||||||
if not Expander_Active then
|
if not Full_Expander_Active then
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -878,7 +878,7 @@ package body Checks is
|
||||||
|
|
||||||
if Backend_Overflow_Checks_On_Target
|
if Backend_Overflow_Checks_On_Target
|
||||||
or else not Do_Overflow_Check (N)
|
or else not Do_Overflow_Check (N)
|
||||||
or else not Expander_Active
|
or else not Full_Expander_Active
|
||||||
or else (Present (Parent (N))
|
or else (Present (Parent (N))
|
||||||
and then Nkind (Parent (N)) = N_Type_Conversion
|
and then Nkind (Parent (N)) = N_Type_Conversion
|
||||||
and then Integer_Promotion_Possible (Parent (N)))
|
and then Integer_Promotion_Possible (Parent (N)))
|
||||||
|
@ -1178,7 +1178,7 @@ package body Checks is
|
||||||
-- Nothing to do if discriminant checks are suppressed or else no code
|
-- Nothing to do if discriminant checks are suppressed or else no code
|
||||||
-- is to be generated
|
-- is to be generated
|
||||||
|
|
||||||
if not Expander_Active
|
if not Full_Expander_Active
|
||||||
or else Discriminant_Checks_Suppressed (T_Typ)
|
or else Discriminant_Checks_Suppressed (T_Typ)
|
||||||
then
|
then
|
||||||
return;
|
return;
|
||||||
|
@ -1462,7 +1462,7 @@ package body Checks is
|
||||||
-- Don't actually use this value
|
-- Don't actually use this value
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Expander_Active
|
if Full_Expander_Active
|
||||||
and then not Backend_Divide_Checks_On_Target
|
and then not Backend_Divide_Checks_On_Target
|
||||||
and then Check_Needed (Right, Division_Check)
|
and then Check_Needed (Right, Division_Check)
|
||||||
then
|
then
|
||||||
|
@ -2118,7 +2118,7 @@ package body Checks is
|
||||||
(not Length_Checks_Suppressed (Target_Typ));
|
(not Length_Checks_Suppressed (Target_Typ));
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Expander_Active then
|
if not Full_Expander_Active then
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -2226,7 +2226,7 @@ package body Checks is
|
||||||
(not Range_Checks_Suppressed (Target_Typ));
|
(not Range_Checks_Suppressed (Target_Typ));
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Expander_Active or else not Checks_On then
|
if not Full_Expander_Active or else not Checks_On then
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -5309,7 +5309,7 @@ package body Checks is
|
||||||
-- enhanced to check for an always True value in the condition and to
|
-- enhanced to check for an always True value in the condition and to
|
||||||
-- generate a compilation warning???
|
-- generate a compilation warning???
|
||||||
|
|
||||||
if not Expander_Active or else not Checks_On then
|
if not Full_Expander_Active or else not Checks_On then
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -6236,7 +6236,7 @@ package body Checks is
|
||||||
-- Start of processing for Selected_Length_Checks
|
-- Start of processing for Selected_Length_Checks
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Expander_Active then
|
if not Full_Expander_Active then
|
||||||
return Ret_Result;
|
return Ret_Result;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -6810,7 +6810,7 @@ package body Checks is
|
||||||
-- Start of processing for Selected_Range_Checks
|
-- Start of processing for Selected_Range_Checks
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Expander_Active then
|
if not Full_Expander_Active then
|
||||||
return Ret_Result;
|
return Ret_Result;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
|
@ -2117,21 +2117,38 @@ package body Exp_Attr is
|
||||||
-- computation to be completed in the back-end, since we don't know what
|
-- computation to be completed in the back-end, since we don't know what
|
||||||
-- layout will be chosen.
|
-- layout will be chosen.
|
||||||
|
|
||||||
when Attribute_First_Bit => First_Bit : declare
|
when Attribute_First_Bit => First_Bit_Attr : declare
|
||||||
CE : constant Entity_Id := Entity (Selector_Name (Pref));
|
CE : constant Entity_Id := Entity (Selector_Name (Pref));
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Known_Static_Component_Bit_Offset (CE) then
|
-- In Ada 2005 (or later) if we have the standard nondefault
|
||||||
|
-- bit order, then we return the original value as given in
|
||||||
|
-- the component clause (RM 2005 13.5.2(3/2)).
|
||||||
|
|
||||||
|
if Present (Component_Clause (CE))
|
||||||
|
and then Ada_Version >= Ada_2005
|
||||||
|
and then not Reverse_Bit_Order (Scope (CE))
|
||||||
|
then
|
||||||
|
Rewrite (N,
|
||||||
|
Make_Integer_Literal (Loc,
|
||||||
|
Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
|
||||||
|
Analyze_And_Resolve (N, Typ);
|
||||||
|
|
||||||
|
-- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
|
||||||
|
-- rewrite with normalized value if we know it statically.
|
||||||
|
|
||||||
|
elsif Known_Static_Component_Bit_Offset (CE) then
|
||||||
Rewrite (N,
|
Rewrite (N,
|
||||||
Make_Integer_Literal (Loc,
|
Make_Integer_Literal (Loc,
|
||||||
Component_Bit_Offset (CE) mod System_Storage_Unit));
|
Component_Bit_Offset (CE) mod System_Storage_Unit));
|
||||||
|
|
||||||
Analyze_And_Resolve (N, Typ);
|
Analyze_And_Resolve (N, Typ);
|
||||||
|
|
||||||
|
-- Otherwise left to back end, just do universal integer checks
|
||||||
|
|
||||||
else
|
else
|
||||||
Apply_Universal_Integer_Attribute_Checks (N);
|
Apply_Universal_Integer_Attribute_Checks (N);
|
||||||
end if;
|
end if;
|
||||||
end First_Bit;
|
end First_Bit_Attr;
|
||||||
|
|
||||||
-----------------
|
-----------------
|
||||||
-- Fixed_Value --
|
-- Fixed_Value --
|
||||||
|
@ -2680,24 +2697,41 @@ package body Exp_Attr is
|
||||||
-- the computation up to the back end, since we don't know what layout
|
-- the computation up to the back end, since we don't know what layout
|
||||||
-- will be chosen.
|
-- will be chosen.
|
||||||
|
|
||||||
when Attribute_Last_Bit => Last_Bit : declare
|
when Attribute_Last_Bit => Last_Bit_Attr : declare
|
||||||
CE : constant Entity_Id := Entity (Selector_Name (Pref));
|
CE : constant Entity_Id := Entity (Selector_Name (Pref));
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Known_Static_Component_Bit_Offset (CE)
|
-- In Ada 2005 (or later) if we have the standard nondefault
|
||||||
|
-- bit order, then we return the original value as given in
|
||||||
|
-- the component clause (RM 2005 13.5.2(4/2)).
|
||||||
|
|
||||||
|
if Present (Component_Clause (CE))
|
||||||
|
and then Ada_Version >= Ada_2005
|
||||||
|
and then not Reverse_Bit_Order (Scope (CE))
|
||||||
|
then
|
||||||
|
Rewrite (N,
|
||||||
|
Make_Integer_Literal (Loc,
|
||||||
|
Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
|
||||||
|
Analyze_And_Resolve (N, Typ);
|
||||||
|
|
||||||
|
-- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
|
||||||
|
-- rewrite with normalized value if we know it statically.
|
||||||
|
|
||||||
|
elsif Known_Static_Component_Bit_Offset (CE)
|
||||||
and then Known_Static_Esize (CE)
|
and then Known_Static_Esize (CE)
|
||||||
then
|
then
|
||||||
Rewrite (N,
|
Rewrite (N,
|
||||||
Make_Integer_Literal (Loc,
|
Make_Integer_Literal (Loc,
|
||||||
Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
|
Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
|
||||||
+ Esize (CE) - 1));
|
+ Esize (CE) - 1));
|
||||||
|
|
||||||
Analyze_And_Resolve (N, Typ);
|
Analyze_And_Resolve (N, Typ);
|
||||||
|
|
||||||
|
-- Otherwise leave to back end, just apply universal integer checks
|
||||||
|
|
||||||
else
|
else
|
||||||
Apply_Universal_Integer_Attribute_Checks (N);
|
Apply_Universal_Integer_Attribute_Checks (N);
|
||||||
end if;
|
end if;
|
||||||
end Last_Bit;
|
end Last_Bit_Attr;
|
||||||
|
|
||||||
------------------
|
------------------
|
||||||
-- Leading_Part --
|
-- Leading_Part --
|
||||||
|
@ -3495,21 +3529,41 @@ package body Exp_Attr is
|
||||||
-- the computation up to the back end, since we don't know what layout
|
-- the computation up to the back end, since we don't know what layout
|
||||||
-- will be chosen.
|
-- will be chosen.
|
||||||
|
|
||||||
when Attribute_Position => Position :
|
when Attribute_Position => Position_Attr :
|
||||||
declare
|
declare
|
||||||
CE : constant Entity_Id := Entity (Selector_Name (Pref));
|
CE : constant Entity_Id := Entity (Selector_Name (Pref));
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Present (Component_Clause (CE)) then
|
if Present (Component_Clause (CE)) then
|
||||||
Rewrite (N,
|
|
||||||
Make_Integer_Literal (Loc,
|
-- In Ada 2005 (or later) if we have the standard nondefault
|
||||||
Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
|
-- bit order, then we return the original value as given in
|
||||||
|
-- the component clause (RM 2005 13.5.2(2/2)).
|
||||||
|
|
||||||
|
if Ada_Version >= Ada_2005
|
||||||
|
and then not Reverse_Bit_Order (Scope (CE))
|
||||||
|
then
|
||||||
|
Rewrite (N,
|
||||||
|
Make_Integer_Literal (Loc,
|
||||||
|
Intval => Expr_Value (Position (Component_Clause (CE)))));
|
||||||
|
|
||||||
|
-- Otherwise (Ada 83 or 95, or reverse bit order specified in
|
||||||
|
-- later Ada version), return the normalized value.
|
||||||
|
|
||||||
|
else
|
||||||
|
Rewrite (N,
|
||||||
|
Make_Integer_Literal (Loc,
|
||||||
|
Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
|
||||||
|
end if;
|
||||||
|
|
||||||
Analyze_And_Resolve (N, Typ);
|
Analyze_And_Resolve (N, Typ);
|
||||||
|
|
||||||
|
-- If back end is doing things, just apply universal integer checks
|
||||||
|
|
||||||
else
|
else
|
||||||
Apply_Universal_Integer_Attribute_Checks (N);
|
Apply_Universal_Integer_Attribute_Checks (N);
|
||||||
end if;
|
end if;
|
||||||
end Position;
|
end Position_Attr;
|
||||||
|
|
||||||
----------
|
----------
|
||||||
-- Pred --
|
-- Pred --
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
|
-- Copyright (C) 2001-2011, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -27,6 +27,7 @@ with Atree; use Atree;
|
||||||
with Casing; use Casing;
|
with Casing; use Casing;
|
||||||
with Checks; use Checks;
|
with Checks; use Checks;
|
||||||
with Einfo; use Einfo;
|
with Einfo; use Einfo;
|
||||||
|
with Errout; use Errout;
|
||||||
with Exp_Util; use Exp_Util;
|
with Exp_Util; use Exp_Util;
|
||||||
with Lib; use Lib;
|
with Lib; use Lib;
|
||||||
with Namet; use Namet;
|
with Namet; use Namet;
|
||||||
|
@ -1065,10 +1066,10 @@ package body Exp_Imgv is
|
||||||
Pref : constant Node_Id := Prefix (N);
|
Pref : constant Node_Id := Prefix (N);
|
||||||
Ptyp : constant Entity_Id := Etype (Pref);
|
Ptyp : constant Entity_Id := Etype (Pref);
|
||||||
Rtyp : constant Entity_Id := Root_Type (Ptyp);
|
Rtyp : constant Entity_Id := Root_Type (Ptyp);
|
||||||
XX : RE_Id;
|
|
||||||
YY : Entity_Id;
|
|
||||||
Arglist : List_Id;
|
Arglist : List_Id;
|
||||||
Ttyp : Entity_Id;
|
Ttyp : Entity_Id;
|
||||||
|
XX : RE_Id;
|
||||||
|
YY : Entity_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Types derived from Standard.Boolean
|
-- Types derived from Standard.Boolean
|
||||||
|
@ -1157,6 +1158,18 @@ package body Exp_Imgv is
|
||||||
|
|
||||||
if Discard_Names (Rtyp) then
|
if Discard_Names (Rtyp) then
|
||||||
|
|
||||||
|
-- Emit a detailed warning in configurable run-time mode because
|
||||||
|
-- loading RE_Null does not give a precise indication of the real
|
||||||
|
-- issue.
|
||||||
|
|
||||||
|
if Configurable_Run_Time_Mode
|
||||||
|
and then not Has_Warnings_Off (Rtyp)
|
||||||
|
then
|
||||||
|
Error_Msg_Name_1 := Attribute_Name (N);
|
||||||
|
Error_Msg_N ("?attribute % not supported in configurable " &
|
||||||
|
"run-time mode", N);
|
||||||
|
end if;
|
||||||
|
|
||||||
-- This is a configurable run-time, or else a restriction is in
|
-- This is a configurable run-time, or else a restriction is in
|
||||||
-- effect. In either case the attribute cannot be supported. Force
|
-- effect. In either case the attribute cannot be supported. Force
|
||||||
-- a load error from Rtsfind to generate an appropriate message,
|
-- a load error from Rtsfind to generate an appropriate message,
|
||||||
|
|
|
@ -4239,7 +4239,8 @@ package body Freeze is
|
||||||
-- By default, if no size clause is present, an enumeration type with
|
-- By default, if no size clause is present, an enumeration type with
|
||||||
-- Convention C is assumed to interface to a C enum, and has integer
|
-- Convention C is assumed to interface to a C enum, and has integer
|
||||||
-- size. This applies to types. For subtypes, verify that its base
|
-- size. This applies to types. For subtypes, verify that its base
|
||||||
-- type has no size clause either.
|
-- type has no size clause either. Treat other foreign conventions
|
||||||
|
-- in the same way, and also make sure alignment is set right.
|
||||||
|
|
||||||
if Has_Foreign_Convention (Typ)
|
if Has_Foreign_Convention (Typ)
|
||||||
and then not Has_Size_Clause (Typ)
|
and then not Has_Size_Clause (Typ)
|
||||||
|
@ -4247,6 +4248,7 @@ package body Freeze is
|
||||||
and then Esize (Typ) < Standard_Integer_Size
|
and then Esize (Typ) < Standard_Integer_Size
|
||||||
then
|
then
|
||||||
Init_Esize (Typ, Standard_Integer_Size);
|
Init_Esize (Typ, Standard_Integer_Size);
|
||||||
|
Set_Alignment (Typ, Alignment (Standard_Integer));
|
||||||
|
|
||||||
else
|
else
|
||||||
-- If the enumeration type interfaces to C, and it has a size clause
|
-- If the enumeration type interfaces to C, and it has a size clause
|
||||||
|
|
|
@ -3088,7 +3088,7 @@ package body Layout is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Here we calculate the alignment as the largest power of two multiple
|
-- Here we calculate the alignment as the largest power of two multiple
|
||||||
-- of System.Storage_Unit that does not exceed either the actual size of
|
-- of System.Storage_Unit that does not exceed either the object size of
|
||||||
-- the type, or the maximum allowed alignment.
|
-- the type, or the maximum allowed alignment.
|
||||||
|
|
||||||
declare
|
declare
|
||||||
|
@ -3126,21 +3126,101 @@ package body Layout is
|
||||||
A := 2 * A;
|
A := 2 * A;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
-- Now we think we should set the alignment to A, but we skip this if
|
-- If alignment is currently not set, then we can safetly set it to
|
||||||
-- an alignment is already set to a value greater than A (happens for
|
-- this new calculated value.
|
||||||
-- derived types).
|
|
||||||
|
|
||||||
-- However, if the alignment is known and too small it must be
|
if Unknown_Alignment (E) then
|
||||||
-- increased, this happens in a case like:
|
|
||||||
|
|
||||||
-- type R is new Character;
|
|
||||||
-- for R'Size use 16;
|
|
||||||
|
|
||||||
-- Here the alignment inherited from Character is 1, but it must be
|
|
||||||
-- increased to 2 to reflect the increased size.
|
|
||||||
|
|
||||||
if Unknown_Alignment (E) or else Alignment (E) < A then
|
|
||||||
Init_Alignment (E, A);
|
Init_Alignment (E, A);
|
||||||
|
|
||||||
|
-- Cases where we have inherited an alignment
|
||||||
|
|
||||||
|
-- For constructed types, always reset the alignment, these are
|
||||||
|
-- Generally invisible to the user anyway, and that way we are
|
||||||
|
-- sure that no constructed types have weird alignments.
|
||||||
|
|
||||||
|
elsif not Comes_From_Source (E) then
|
||||||
|
Init_Alignment (E, A);
|
||||||
|
|
||||||
|
-- If this inherited alignment is the same as the one we computed,
|
||||||
|
-- then obviously everything is fine, and we do not need to reset it.
|
||||||
|
|
||||||
|
elsif Alignment (E) = A then
|
||||||
|
null;
|
||||||
|
|
||||||
|
-- Now we come to the difficult cases where we have inherited an
|
||||||
|
-- alignment and size, but overridden the size but not the alignment.
|
||||||
|
|
||||||
|
elsif Has_Size_Clause (E) or else Has_Object_Size_Clause (E) then
|
||||||
|
|
||||||
|
-- This is tricky, it might be thought that we should try to
|
||||||
|
-- inherit the alignment, since that's what the RM implies, but
|
||||||
|
-- that leads to complex rules and oddities. Consider for example:
|
||||||
|
|
||||||
|
-- type R is new Character;
|
||||||
|
-- for R'Size use 16;
|
||||||
|
|
||||||
|
-- It seems quite bogus in this case to inherit an alignment of 1
|
||||||
|
-- from the parent type Character. Furthermore, if that's what the
|
||||||
|
-- programmer really wanted for some odd reason, then they could
|
||||||
|
-- specify the alignment they wanted.
|
||||||
|
|
||||||
|
-- Furthermore we really don't want to inherit the alignment in
|
||||||
|
-- the case of a specified Object_Size for a subtype, since then
|
||||||
|
-- there would be no way of overriding to give a reasonable value
|
||||||
|
-- (we don't have an Object_Subtype attribute). Consider:
|
||||||
|
|
||||||
|
-- subtype R is new Character;
|
||||||
|
-- for R'Object_Size use 16;
|
||||||
|
|
||||||
|
-- If we inherit the alignment of 1, then we have an odd
|
||||||
|
-- inefficient alignment for the subtype, which cannot be fixed.
|
||||||
|
|
||||||
|
-- So we make the decision that if Size (or Object_Size) is given
|
||||||
|
-- (and, in the case of a first subtype, the alignment is not set
|
||||||
|
-- with a specific alignment clause). We reset the alignment to
|
||||||
|
-- the appropriate value for the specified size. This is a nice
|
||||||
|
-- simple rule to implement and document.
|
||||||
|
|
||||||
|
-- There is one slight glitch, which is that a confirming size
|
||||||
|
-- clause can now change the alignment, which, if we really think
|
||||||
|
-- that confirming rep clauses should have no effect, is a no-no.
|
||||||
|
|
||||||
|
-- type R is new Character;
|
||||||
|
-- for R'Alignment use 2;
|
||||||
|
-- type S is new R;
|
||||||
|
-- for S'Size use Character'Size;
|
||||||
|
|
||||||
|
-- Now the alignment of S is 1 instead of 2, as a result of
|
||||||
|
-- applying the above rule to the confirming rep clause for S. Not
|
||||||
|
-- clear this is worth worrying about. If we recorded whether a
|
||||||
|
-- size clause was confirming we could avoid this, but right now
|
||||||
|
-- we have no way of doing that or easily figuring it out, so we
|
||||||
|
-- don't bother.
|
||||||
|
|
||||||
|
-- Historical note. In versions of GNAT prior to Nov 6th, 2010, an
|
||||||
|
-- odd distinction was made between inherited alignments greater
|
||||||
|
-- than the computed alignment (where the larger alignment was
|
||||||
|
-- inherited) and inherited alignments smaller than the computed
|
||||||
|
-- alignment (where the smaller alignment was overridden). This
|
||||||
|
-- was a dubious fix to get around an ACATS problem which seems
|
||||||
|
-- to have disappeared anyway, and in any case, this peculiarity
|
||||||
|
-- was never documented.
|
||||||
|
|
||||||
|
Init_Alignment (E, A);
|
||||||
|
|
||||||
|
-- If no Size (or Object_Size) was specified, then we inherited the
|
||||||
|
-- object size, so we should inherit the alignment as well and not
|
||||||
|
-- modify it. This takes care of cases like:
|
||||||
|
|
||||||
|
-- type R is new Integer;
|
||||||
|
-- for R'Alignment use 1;
|
||||||
|
-- subtype S is R;
|
||||||
|
|
||||||
|
-- Here we have R has a default Object_Size of 32, and a specified
|
||||||
|
-- alignment of 1, and it seeems right for S to inherit both values.
|
||||||
|
|
||||||
|
else
|
||||||
|
null;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
end Set_Elem_Alignment;
|
end Set_Elem_Alignment;
|
||||||
|
|
|
@ -2553,6 +2553,11 @@ package body Ch4 is
|
||||||
Node1 : Node_Id;
|
Node1 : Node_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
if Ada_Version < Ada_2012 then
|
||||||
|
Error_Msg_SC ("quantified expression is an Ada 2012 feature");
|
||||||
|
Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
|
||||||
|
end if;
|
||||||
|
|
||||||
Scan; -- past FOR
|
Scan; -- past FOR
|
||||||
|
|
||||||
Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);
|
Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);
|
||||||
|
|
|
@ -50,7 +50,12 @@ package body System.Atomic_Counters is
|
||||||
|
|
||||||
function Decrement (Item : in out Atomic_Counter) return Boolean is
|
function Decrement (Item : in out Atomic_Counter) return Boolean is
|
||||||
begin
|
begin
|
||||||
return Sync_Sub_And_Fetch (Item.Value'Access, 1) = 0;
|
-- Note: the use of Unrestricted_Access here is required because we
|
||||||
|
-- are obtaining an access-to-volatile pointer to a non-volatile object.
|
||||||
|
-- This is not allowed for [Unchecked_]Access, but is safe in this case
|
||||||
|
-- because we know that no aliases are being created.
|
||||||
|
|
||||||
|
return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0;
|
||||||
end Decrement;
|
end Decrement;
|
||||||
|
|
||||||
---------------
|
---------------
|
||||||
|
@ -59,7 +64,12 @@ package body System.Atomic_Counters is
|
||||||
|
|
||||||
procedure Increment (Item : in out Atomic_Counter) is
|
procedure Increment (Item : in out Atomic_Counter) is
|
||||||
begin
|
begin
|
||||||
Sync_Add_And_Fetch (Item.Value'Access, 1);
|
-- Note: the use of Unrestricted_Access here is required because we
|
||||||
|
-- are obtaining an access-to-volatile pointer to a non-volatile object.
|
||||||
|
-- This is not allowed for [Unchecked_]Access, but is safe in this case
|
||||||
|
-- because we know that no aliases are being created.
|
||||||
|
|
||||||
|
Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1);
|
||||||
end Increment;
|
end Increment;
|
||||||
|
|
||||||
------------
|
------------
|
||||||
|
|
|
@ -181,6 +181,12 @@ package body System.Finalization_Masters is
|
||||||
|
|
||||||
if Master.Finalization_Started then
|
if Master.Finalization_Started then
|
||||||
Unlock_Task.all;
|
Unlock_Task.all;
|
||||||
|
|
||||||
|
-- Double finalization may occur during the handling of stand alone
|
||||||
|
-- libraries or the finalization of a pool with subpools. Due to the
|
||||||
|
-- potential aliasing of masters in these two cases, do not process
|
||||||
|
-- the same master twice.
|
||||||
|
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
|
@ -990,11 +990,18 @@ package body System.Task_Primitives.Operations is
|
||||||
-- do not need to manipulate caller's signal mask at this point.
|
-- do not need to manipulate caller's signal mask at this point.
|
||||||
-- All tasks in RTS will have All_Tasks_Mask initially.
|
-- All tasks in RTS will have All_Tasks_Mask initially.
|
||||||
|
|
||||||
Result := pthread_create
|
-- Note: the use of Unrestricted_Access in the following call is needed
|
||||||
(T.Common.LL.Thread'Access,
|
-- because otherwise we have an error of getting a access-to-volatile
|
||||||
Attributes'Access,
|
-- value which points to a non-volatile object. But in this case it is
|
||||||
Thread_Body_Access (Wrapper),
|
-- safe to do this, since we know we have no problems with aliasing and
|
||||||
To_Address (T));
|
-- Unrestricted_Access bypasses this check.
|
||||||
|
|
||||||
|
Result :=
|
||||||
|
pthread_create
|
||||||
|
(T.Common.LL.Thread'Unrestricted_Access,
|
||||||
|
Attributes'Access,
|
||||||
|
Thread_Body_Access (Wrapper),
|
||||||
|
To_Address (T));
|
||||||
|
|
||||||
pragma Assert
|
pragma Assert
|
||||||
(Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
|
(Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
|
||||||
|
|
|
@ -811,7 +811,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
Result :=
|
Result :=
|
||||||
pthread_create
|
pthread_create
|
||||||
(T.Common.LL.Thread'Access,
|
(T.Common.LL.Thread'Unrestricted_Access,
|
||||||
Attributes'Access,
|
Attributes'Access,
|
||||||
Thread_Body_Access (Wrapper),
|
Thread_Body_Access (Wrapper),
|
||||||
To_Address (T));
|
To_Address (T));
|
||||||
|
|
|
@ -726,13 +726,33 @@ package body Sem_Ch3 is
|
||||||
|
|
||||||
-- If the access definition is the return type of another access to
|
-- If the access definition is the return type of another access to
|
||||||
-- function, scope is the current one, because it is the one of the
|
-- function, scope is the current one, because it is the one of the
|
||||||
-- current type declaration.
|
-- current type declaration, except for the pathological case below.
|
||||||
|
|
||||||
if Nkind_In (Related_Nod, N_Object_Declaration,
|
if Nkind_In (Related_Nod, N_Object_Declaration,
|
||||||
N_Access_Function_Definition)
|
N_Access_Function_Definition)
|
||||||
then
|
then
|
||||||
Anon_Scope := Current_Scope;
|
Anon_Scope := Current_Scope;
|
||||||
|
|
||||||
|
-- A pathological case: function returning access functions that
|
||||||
|
-- return access functions, etc. Each anonymous access type created
|
||||||
|
-- is in the enclosing scope of the outermost function.
|
||||||
|
|
||||||
|
declare
|
||||||
|
Par : Node_Id;
|
||||||
|
begin
|
||||||
|
Par := Related_Nod;
|
||||||
|
while Nkind_In (Par,
|
||||||
|
N_Access_Function_Definition,
|
||||||
|
N_Access_Definition)
|
||||||
|
loop
|
||||||
|
Par := Parent (Par);
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
if Nkind (Par) = N_Function_Specification then
|
||||||
|
Anon_Scope := Scope (Defining_Entity (Par));
|
||||||
|
end if;
|
||||||
|
end;
|
||||||
|
|
||||||
-- For the anonymous function result case, retrieve the scope of the
|
-- For the anonymous function result case, retrieve the scope of the
|
||||||
-- function specification's associated entity rather than using the
|
-- function specification's associated entity rather than using the
|
||||||
-- current scope. The current scope will be the function itself if the
|
-- current scope. The current scope will be the function itself if the
|
||||||
|
|
|
@ -11069,6 +11069,11 @@ package body Sem_Res is
|
||||||
N);
|
N);
|
||||||
return True;
|
return True;
|
||||||
|
|
||||||
|
-- If it was legal in the generic, it's legal in the instance
|
||||||
|
|
||||||
|
elsif In_Instance_Body then
|
||||||
|
return True;
|
||||||
|
|
||||||
-- If both are tagged types, check legality of view conversions
|
-- If both are tagged types, check legality of view conversions
|
||||||
|
|
||||||
elsif Is_Tagged_Type (Target_Type)
|
elsif Is_Tagged_Type (Target_Type)
|
||||||
|
|
|
@ -8727,10 +8727,15 @@ package body Sem_Util is
|
||||||
then
|
then
|
||||||
return True;
|
return True;
|
||||||
|
|
||||||
elsif Nkind (N) = N_Indexed_Component
|
elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
|
||||||
or else Nkind (N) = N_Selected_Component
|
and then Is_Volatile_Prefix (Prefix (N))
|
||||||
then
|
then
|
||||||
return Is_Volatile_Prefix (Prefix (N));
|
return True;
|
||||||
|
|
||||||
|
elsif Nkind (N) = N_Selected_Component
|
||||||
|
and then Is_Volatile (Entity (Selector_Name (N)))
|
||||||
|
then
|
||||||
|
return True;
|
||||||
|
|
||||||
else
|
else
|
||||||
return False;
|
return False;
|
||||||
|
@ -10833,9 +10838,7 @@ package body Sem_Util is
|
||||||
-- source. This excludes, for example, calls to a dispatching
|
-- source. This excludes, for example, calls to a dispatching
|
||||||
-- assignment operation when the left-hand side is tagged.
|
-- assignment operation when the left-hand side is tagged.
|
||||||
|
|
||||||
if Modification_Comes_From_Source
|
if Modification_Comes_From_Source or else Alfa_Mode then
|
||||||
or else Alfa_Mode
|
|
||||||
then
|
|
||||||
Generate_Reference (Ent, Exp, 'm');
|
Generate_Reference (Ent, Exp, 'm');
|
||||||
|
|
||||||
-- If the target of the assignment is the bound variable
|
-- If the target of the assignment is the bound variable
|
||||||
|
|
|
@ -477,13 +477,13 @@ package Sinput is
|
||||||
|
|
||||||
-- In addition to the set of characters defined by the type in Types, in
|
-- In addition to the set of characters defined by the type in Types, in
|
||||||
-- wide character encoding, then the codes returning True for a call to
|
-- wide character encoding, then the codes returning True for a call to
|
||||||
-- System.UTF_32.Is_UTF_32_Line_Terminator are also recognized as ending
|
-- System.UTF_32.Is_UTF_32_Line_Terminator are also recognized as ending a
|
||||||
-- a physical source line. This includes the standard codes defined above
|
-- source line. This includes the standard codes defined above in addition
|
||||||
-- in addition to NEL (NEXT LINE), LINE SEPARATOR and PARAGRAPH SEPARATOR.
|
-- to NEL (NEXT LINE), LINE SEPARATOR and PARAGRAPH SEPARATOR. Again, as in
|
||||||
-- Again, as in the case of VT and FF, the standard requires we recognize
|
-- the case of VT and FF, the standard requires we recognize these as line
|
||||||
-- these as line terminators, but we consider them to be logical line
|
-- terminators, but we consider them to be logical line terminators. The
|
||||||
-- terminators. The only physical line terminators recognized are the
|
-- only physical line terminators recognized are the standard ones (CR,
|
||||||
-- standard ones (CR, LF, or CR/LF).
|
-- LF, or CR/LF).
|
||||||
|
|
||||||
-- However, we do not recognize the NEL (16#85#) character as having the
|
-- However, we do not recognize the NEL (16#85#) character as having the
|
||||||
-- significance of an end of line character when operating in normal 8-bit
|
-- significance of an end of line character when operating in normal 8-bit
|
||||||
|
|
Loading…
Reference in New Issue