Commit d5aa443c by Arnaud Charlet

[multiple changes]

2011-09-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch9.adb (Install_Private_Data_Declarations): Add guards
	which ensure that restriction No_Dynamic_Attachment has not been
	violated.
	(Make_Initialize_Protection): Protected types with attach or
	interrupt handlers must not violate restriction No_Dynamic_Attachment.
	* exp_util.adb (Corresponding_Runtime_Package): Add a guard
	which ensures that restriction No_Dynamic_Attachment has not been
	violated.
	* sem_attr.adb: (Eval_Attribute): Transform
	VAX_Float_Type'First and 'Last into references to
	the temporaries which store the corresponding bounds. The
	transformation is needed since the back end cannot evaluate
	'First and 'Last on VAX.
	(Is_VAX_Float): New routine.

2011-09-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Analyze_Subprogram_Instantiation): If the
	generic unit is not intrinsic and has an explicit convention,
	the instance inherits it.

From-SVN: r178449
parent 67c86178
2011-09-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch9.adb (Install_Private_Data_Declarations): Add guards
which ensure that restriction No_Dynamic_Attachment has not been
violated.
(Make_Initialize_Protection): Protected types with attach or
interrupt handlers must not violate restriction No_Dynamic_Attachment.
* exp_util.adb (Corresponding_Runtime_Package): Add a guard
which ensures that restriction No_Dynamic_Attachment has not been
violated.
* sem_attr.adb: (Eval_Attribute): Transform
VAX_Float_Type'First and 'Last into references to
the temporaries which store the corresponding bounds. The
transformation is needed since the back end cannot evaluate
'First and 'Last on VAX.
(Is_VAX_Float): New routine.
2011-09-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Analyze_Subprogram_Instantiation): If the
generic unit is not intrinsic and has an explicit convention,
the instance inherits it.
2011-09-02 Robert Dewar <dewar@adacore.com> 2011-09-02 Robert Dewar <dewar@adacore.com>
* prj-dect.adb, prj-env.adb, prj-nmsc.adb, prj-proc.adb, prj-tree.adb, * prj-dect.adb, prj-env.adb, prj-nmsc.adb, prj-proc.adb, prj-tree.adb,
......
...@@ -12031,10 +12031,13 @@ package body Exp_Ch9 is ...@@ -12031,10 +12031,13 @@ package body Exp_Ch9 is
if Has_Attach_Handler (Conc_Typ) if Has_Attach_Handler (Conc_Typ)
and then not Restricted_Profile and then not Restricted_Profile
and then not Restriction_Active (No_Dynamic_Attachment)
then then
Prot_Typ := RE_Static_Interrupt_Protection; Prot_Typ := RE_Static_Interrupt_Protection;
elsif Has_Interrupt_Handler (Conc_Typ) then elsif Has_Interrupt_Handler (Conc_Typ)
and then not Restriction_Active (No_Dynamic_Attachment)
then
Prot_Typ := RE_Dynamic_Interrupt_Protection; Prot_Typ := RE_Dynamic_Interrupt_Protection;
-- The type has explicit entries or generated primitive entry -- The type has explicit entries or generated primitive entry
...@@ -12451,8 +12454,8 @@ package body Exp_Ch9 is ...@@ -12451,8 +12454,8 @@ package body Exp_Ch9 is
-- When no priority is specified but an xx_Handler pragma is, we default -- When no priority is specified but an xx_Handler pragma is, we default
-- to System.Interrupts.Default_Interrupt_Priority, see D.3(10). -- to System.Interrupts.Default_Interrupt_Priority, see D.3(10).
elsif Has_Interrupt_Handler (Ptyp) elsif (Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp))
or else Has_Attach_Handler (Ptyp) and then not Restriction_Active (No_Dynamic_Attachment)
then then
Append_To (Args, Append_To (Args,
New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc)); New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
...@@ -12475,9 +12478,10 @@ package body Exp_Ch9 is ...@@ -12475,9 +12478,10 @@ package body Exp_Ch9 is
-- context of dispatching select statements. -- context of dispatching select statements.
if Has_Entry if Has_Entry
or else Has_Interrupt_Handler (Ptyp)
or else Has_Attach_Handler (Ptyp)
or else Has_Interfaces (Protect_Rec) or else Has_Interfaces (Protect_Rec)
or else
((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp))
and then not Restriction_Active (No_Dynamic_Attachment))
then then
declare declare
Pkg_Id : constant RTU_Id := Pkg_Id : constant RTU_Id :=
......
...@@ -1515,9 +1515,6 @@ package body Exp_Util is ...@@ -1515,9 +1515,6 @@ package body Exp_Util is
if Ekind (Typ) in Protected_Kind then if Ekind (Typ) in Protected_Kind then
if Has_Entries (Typ) if Has_Entries (Typ)
or else Has_Interrupt_Handler (Typ)
or else (Has_Attach_Handler (Typ)
and then not Restricted_Profile)
-- A protected type without entries that covers an interface and -- A protected type without entries that covers an interface and
-- overrides the abstract routines with protected procedures is -- overrides the abstract routines with protected procedures is
...@@ -1527,6 +1524,10 @@ package body Exp_Util is ...@@ -1527,6 +1524,10 @@ package body Exp_Util is
-- node to recognize this case. -- node to recognize this case.
or else Present (Interface_List (Parent (Typ))) or else Present (Interface_List (Parent (Typ)))
or else
(((Has_Attach_Handler (Typ) and then not Restricted_Profile)
or else Has_Interrupt_Handler (Typ))
and then not Restriction_Active (No_Dynamic_Attachment))
then then
if Abort_Allowed if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False or else Restriction_Active (No_Entry_Queue) = False
......
...@@ -5260,6 +5260,9 @@ package body Sem_Attr is ...@@ -5260,6 +5260,9 @@ package body Sem_Attr is
-- Computes the Fore value for the current attribute prefix, which is -- Computes the Fore value for the current attribute prefix, which is
-- known to be a static fixed-point type. Used by Fore and Width. -- known to be a static fixed-point type. Used by Fore and Width.
function Is_VAX_Float (Typ : Entity_Id) return Boolean;
-- Determine whether Typ denotes a VAX floating point type
function Mantissa return Uint; function Mantissa return Uint;
-- Returns the Mantissa value for the prefix type -- Returns the Mantissa value for the prefix type
...@@ -5390,6 +5393,19 @@ package body Sem_Attr is ...@@ -5390,6 +5393,19 @@ package body Sem_Attr is
return R; return R;
end Fore_Value; end Fore_Value;
------------------
-- Is_VAX_Float --
------------------
function Is_VAX_Float (Typ : Entity_Id) return Boolean is
begin
return
Is_Floating_Point_Type (Typ)
and then
(Float_Format = 'V'
or else Float_Rep (Typ) = VAX_Native);
end Is_VAX_Float;
-------------- --------------
-- Mantissa -- -- Mantissa --
-------------- --------------
...@@ -6337,6 +6353,16 @@ package body Sem_Attr is ...@@ -6337,6 +6353,16 @@ package body Sem_Attr is
Fold_Uint (N, Expr_Value (Lo_Bound), Static); Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if; end if;
-- Replace VAX Float_Type'First with a reference to the temporary
-- which represents the low bound of the type. This transformation
-- is needed since the back end cannot evaluate 'First on VAX.
elsif Is_VAX_Float (P_Type)
and then Nkind (Lo_Bound) = N_Identifier
then
Rewrite (N, New_Reference_To (Entity (Lo_Bound), Sloc (N)));
Analyze (N);
else else
Check_Concurrent_Discriminant (Lo_Bound); Check_Concurrent_Discriminant (Lo_Bound);
end if; end if;
...@@ -6528,6 +6554,16 @@ package body Sem_Attr is ...@@ -6528,6 +6554,16 @@ package body Sem_Attr is
Fold_Uint (N, Expr_Value (Hi_Bound), Static); Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if; end if;
-- Replace VAX Float_Type'Last with a reference to the temporary
-- which represents the high bound of the type. This transformation
-- is needed since the back end cannot evaluate 'Last on VAX.
elsif Is_VAX_Float (P_Type)
and then Nkind (Hi_Bound) = N_Identifier
then
Rewrite (N, New_Reference_To (Entity (Hi_Bound), Sloc (N)));
Analyze (N);
else else
Check_Concurrent_Discriminant (Hi_Bound); Check_Concurrent_Discriminant (Hi_Bound);
end if; end if;
......
...@@ -4430,8 +4430,6 @@ package body Sem_Ch12 is ...@@ -4430,8 +4430,6 @@ package body Sem_Ch12 is
-- for the compilation, we generate the instance body even if it is -- for the compilation, we generate the instance body even if it is
-- not within the main unit. -- not within the main unit.
-- Any other pragmas might also be inherited ???
if Is_Intrinsic_Subprogram (Gen_Unit) then if Is_Intrinsic_Subprogram (Gen_Unit) then
Set_Is_Intrinsic_Subprogram (Anon_Id); Set_Is_Intrinsic_Subprogram (Anon_Id);
Set_Is_Intrinsic_Subprogram (Act_Decl_Id); Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
...@@ -4441,6 +4439,17 @@ package body Sem_Ch12 is ...@@ -4441,6 +4439,17 @@ package body Sem_Ch12 is
end if; end if;
end if; end if;
-- Inherit convention from generic unit. Intrinsic convention, as for
-- an instance of unchecked conversion, is not inherited because an
-- explicit Ada instance has been created.
if Has_Convention_Pragma (Gen_Unit)
and then Convention (Gen_Unit) /= Convention_Intrinsic
then
Set_Convention (Act_Decl_Id, Convention (Gen_Unit));
Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit));
end if;
Generate_Definition (Act_Decl_Id); Generate_Definition (Act_Decl_Id);
Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id))); -- ??? needed? Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id))); -- ??? needed?
Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id))); Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id)));
...@@ -4479,8 +4488,6 @@ package body Sem_Ch12 is ...@@ -4479,8 +4488,6 @@ package body Sem_Ch12 is
Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
-- Subject to change, pending on if other pragmas are inherited ???
Validate_Categorization_Dependency (N, Act_Decl_Id); Validate_Categorization_Dependency (N, Act_Decl_Id);
if not Is_Intrinsic_Subprogram (Act_Decl_Id) then if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment