[Ada] Improvements in handling of attributes
Arnaud Charlet
charlet@adacore.com
Tue Nov 15 14:34:00 GMT 2005
Tested on i686-linux, committed on trunk
To give support to the use of the attributes 'Unchecked_Access
with objects implementing abstract interfaces we perform an
implicit type conversion that will displace the pointer to
secondary dispatch table associated with the abstract
interface. The correct execution of this test must generate
the following sequence: 222222
--
with Ada.Text_IO; use Ada.Text_IO;
procedure Do_Test is
package Pkg is
type I1 is protected interface;
procedure Op1 (S : in out I1) is abstract;
type I2 is protected interface;
procedure Op2 (S : in out I2) is abstract;
end Pkg;
use Pkg;
protected type PO is new I1 and I2 with
procedure Op1;
procedure Op2;
end PO;
protected body PO is
procedure Op1 is begin Put ("1"); end;
procedure Op2 is begin Put ("2"); end;
end PO;
type Any_I2 is access all I2'Class;
procedure Do_Test_1 (Obj : Any_I2) is
begin
Obj.Op2;
end Do_Test_1;
procedure Do_Test_2 (Obj : access I2'Class) is
begin
Obj.Op2;
end Do_Test_2;
My_PO : aliased PO;
begin
Do_Test_1 (My_PO'Access);
Do_Test_1 (My_PO'Unchecked_Access);
Do_Test_1 (My_PO'Unrestricted_Access);
Do_Test_2 (My_PO'Access);
Do_Test_2 (My_PO'Unchecked_Access);
Do_Test_2 (My_PO'Unrestricted_Access);
end Do_Test;
This patch also adds support for AI-345, more specifically to attributes
'Callable and 'Terminated as well as Abort for task interface class-wide types.
Finally, the handling of floating-point attributes for the Vax_Float cases
was quite wrong, since all attributes were resolved into calls to
units instantiated from System.Fat_Gen for types in Standard. This
was wrong for vax float types when the types in standard were IEEE,
and also for IEEE types when the types in standard were vax float
(the latter situation arises for explicit use of IEEE types with a
library recompiled with a Float_Representation configuration pragma
to force vax float representation for the types in standard.
The approach in this patch is to introduce five additional packages
instantiating System.Fat_Gen for the three vax float types, and IEEE
short and long forms. These additional packages are used in thw two
cases above to ensure a proper match bewteen the source and the
run time routine used to compute the attribute.
The following test program should be compiled with -gnatGdm
procedure A is
pragma Warnings (Off);
type D is digits 9;
pragma Float_Representation (VAX_Float, D);
type G is digits 15;
pragma Float_Representation (VAX_Float, G);
type F is digits 6;
pragma Float_Representation (VAX_Float, F);
type S is digits 6;
pragma Float_Representation (IEEE_Float, S);
type T is digits 15;
pragma Float_Representation (IEEE_Float, T);
DD : D;
GG : G;
FF : F;
SS : S;
TT : T;
B : Boolean;
begin
DD := D'Floor (DD);
GG := G'Floor (GG);
FF := F'Floor (FF);
SS := S'Floor (SS);
TT := T'Floor (TT);
DD := D'Scaling (DD, 1);
GG := G'Scaling (GG, 1);
FF := F'Scaling (FF, 1);
SS := S'Scaling (SS, 1);
TT := T'Scaling (TT, 1);
DD := D'Remainder (DD, DD);
GG := G'Remainder (GG, GG);
FF := F'Remainder (FF, FF);
SS := S'Remainder (SS, SS);
TT := T'Remainder (TT, TT);
B := DD'Valid;
B := GG'Valid;
B := FF'Valid;
B := SS'Valid;
B := TT'Valid;
end;
The output of the compilation should be (programs compiled with
-gnatdm, forcing vax mode, cannot be bound and executed):
Source recreated from tree for A (body)
---------------------------------------
with system.system__fat_vax_d_float;
with system.system__fat_vax_g_float;
with system.system__fat_vax_f_float;
with system.system__fat_sflt;
with system.system__fat_lflt;
with system;
with system.system__vax_float_operations;
procedure a is
pragma warnings (off);
type a__d is digits 9;
pragma float_representation (vax_float, a__d);
type a__g is digits 15;
pragma float_representation (vax_float, a__g);
type a__f is digits 6;
pragma float_representation (vax_float, a__f);
type a__s is digits 6;
pragma float_representation (ieee_float, a__s);
type a__t is digits 15;
pragma float_representation (ieee_float, a__t);
dd : a__d;
gg : a__g;
ff : a__f;
ss : a__s;
tt : a__t;
b : boolean;
begin
dd := a__TdB!(system__fat_vax_d_float__attr_vax_d_float.
system__fat_vax_d_float__attr_vax_d_float__floor (
system__fat_vax_d_float__fat_vax_d!(dd)));
gg := a__TgB!(system__fat_vax_g_float__attr_vax_g_float.
system__fat_vax_g_float__attr_vax_g_float__floor (
system__fat_vax_g_float__fat_vax_g!(gg)));
ff := a__TfB!(system__fat_vax_f_float__attr_vax_f_float.
system__fat_vax_f_float__attr_vax_f_float__floor (
system__fat_vax_f_float__fat_vax_f!(ff)));
ss := a__TsB!(system__fat_sflt__attr_short_float.
system__fat_sflt__attr_short_float__floor (short_float!(ss)));
tt := a__TtB!(system__fat_lflt__attr_long_float.
system__fat_lflt__attr_long_float__floor (long_float!(tt)));
dd := a__TdB!(system__fat_vax_d_float__attr_vax_d_float.
system__fat_vax_d_float__attr_vax_d_float__scaling (
system__fat_vax_d_float__fat_vax_d!(dd), 1));
gg := a__TgB!(system__fat_vax_g_float__attr_vax_g_float.
system__fat_vax_g_float__attr_vax_g_float__scaling (
system__fat_vax_g_float__fat_vax_g!(gg), 1));
ff := a__TfB!(system__fat_vax_f_float__attr_vax_f_float.
system__fat_vax_f_float__attr_vax_f_float__scaling (
system__fat_vax_f_float__fat_vax_f!(ff), 1));
ss := a__TsB!(system__fat_sflt__attr_short_float.
system__fat_sflt__attr_short_float__scaling (short_float!(ss),
1));
tt := a__TtB!(system__fat_lflt__attr_long_float.
system__fat_lflt__attr_long_float__scaling (long_float!(tt), 1));
dd := a__TdB!(system__fat_vax_d_float__attr_vax_d_float.
system__fat_vax_d_float__attr_vax_d_float__remainder (
system__fat_vax_d_float__fat_vax_d!(dd),
system__fat_vax_d_float__fat_vax_d!(dd)));
gg := a__TgB!(system__fat_vax_g_float__attr_vax_g_float.
system__fat_vax_g_float__attr_vax_g_float__remainder (
system__fat_vax_g_float__fat_vax_g!(gg),
system__fat_vax_g_float__fat_vax_g!(gg)));
ff := a__TfB!(system__fat_vax_f_float__attr_vax_f_float.
system__fat_vax_f_float__attr_vax_f_float__remainder (
system__fat_vax_f_float__fat_vax_f!(ff),
system__fat_vax_f_float__fat_vax_f!(ff)));
ss := a__TsB!(system__fat_sflt__attr_short_float.
system__fat_sflt__attr_short_float__remainder (short_float!(ss),
short_float!(ss)));
tt := a__TtB!(system__fat_lflt__attr_long_float.
system__fat_lflt__attr_long_float__remainder (long_float!(tt),
long_float!(tt)));
b := system__vax_float_operations__valid_g (
system__vax_float_operations__d_to_g (
system__vax_float_operations__TdB!(dd)));
b := system__vax_float_operations__valid_g (
system__vax_float_operations__TgB!(gg));
b := system__vax_float_operations__valid_f (
system__vax_float_operations__TfB!(ff));
b := boolean!(system__fat_sflt__attr_short_float.
system__fat_sflt__attr_short_float__valid (short_float!(ss)'
unrestricted_access, xF => 0));
b := boolean!(system__fat_lflt__attr_long_float.
system__fat_lflt__attr_long_float__valid (long_float!(tt)'
unrestricted_access, xF => 0));
return;
end a;
2005-11-14 Javier Miranda <miranda@adacore.com>
Robert Dewar <dewar@adacore.com>
Hristian Kirtchev <kirtchev@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference, cases of Attribute_Size
and related): For a prefix that is an explicit dereference of an
access to unconstrained packed array type, annotate the dereference
with an actual subtype so GIGI can make a correct size computation.
(Expand_N_Attribute_Reference): In case of 'Unchecked_Access and
'Unrestricted_Access, if the designated type is an interface we
add a type conversion to force the displacement of the pointer
to the secondary dispatch table.
Use Universal_Real instead of Long_Long_Float when we need a high
precision float type for the generated code (prevents gratuitous
Vax_Float stuff when pragma Float_Representation (Vax_Float) used)
(Expand_N_Attribute_Reference): Add support for attribute 'Callable and
'Terminated for task interface class-wide objects. Generate a call to
the predefined dispatching routine used to retrieve the _task_id from
a task corresponding record.
(Expand_Fpt_Attribute): Major change to properly handle Vax_Float
* sem_disp.adb: Change name Is_Package to Is_Package_Or_Generic_Package
(Check_Dispatching_Operation): Protect the frontend againts
previously detected errors.
* Makefile.rtl: Add new instantiations of system.fat_gen
* s-fatflt.ads, s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads:
Change name of instantiated package for better consistency
with newly added system.fat_gen instantiations.
* s-filofl.ads, s-fishfl.ads, s-fvadfl.ads, s-fvaffl.ads,
s-fvagfl.ads: New files.
-------------- next part --------------
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 106884)
+++ exp_attr.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
@@ -85,16 +85,17 @@
procedure Expand_Fpt_Attribute
(N : Node_Id;
- Rtp : Entity_Id;
+ Pkg : RE_Id;
Nam : Name_Id;
Args : List_Id);
-- This procedure expands a call to a floating-point attribute function.
-- N is the attribute reference node, and Args is a list of arguments to
- -- be passed to the function call. Rtp is the root type of the floating
- -- point type involved (used to select the proper generic instantiation
- -- of the package containing the attribute routines). The Nam argument
- -- is the attribute processing routine to be called. This is normally
- -- the same as the attribute name, except in the Unaligned_Valid case.
+ -- be passed to the function call. Pkg identifies the package containing
+ -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
+ -- have already been converted to the floating-point type for which Pkg was
+ -- instantiated. The Nam argument is the relevant attribute processing
+ -- routine to be called. This is the same as the attribute name, except in
+ -- the Unaligned_Valid case.
procedure Expand_Fpt_Attribute_R (N : Node_Id);
-- This procedure expands a call to a floating-point attribute function
@@ -123,6 +124,15 @@
-- A reference to a type within its own scope is resolved to a reference
-- to the current instance of the type in its initialization procedure.
+ procedure Find_Fat_Info
+ (T : Entity_Id;
+ Fat_Type : out Entity_Id;
+ Fat_Pkg : out RE_Id);
+ -- Given a floating-point type T, identifies the package containing the
+ -- attributes for this type (returned in Fat_Pkg), and the corresponding
+ -- type for which this package was instantiated from Fat_Gen. Error if T
+ -- is not a floating-point type.
+
function Find_Stream_Subprogram
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id;
@@ -176,7 +186,7 @@
if Check then
Insert_Action (N, Decl);
else
- Insert_Action (N, Decl, All_Checks);
+ Insert_Action (N, Decl, Suppress => All_Checks);
end if;
if Installed then
@@ -260,18 +270,17 @@
procedure Expand_Fpt_Attribute
(N : Node_Id;
- Rtp : Entity_Id;
+ Pkg : RE_Id;
Nam : Name_Id;
Args : List_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
- Pkg : RE_Id;
Fnm : Node_Id;
begin
- -- The function name is the selected component Fat_xxx.yyy where xxx
- -- is the floating-point root type, and yyy is the argument Nam.
+ -- The function name is the selected component Attr_xxx.yyy where
+ -- Attr_xxx is the package name, and yyy is the argument Nam.
-- Note: it would be more usual to have separate RE entries for each
-- of the entities in the Fat packages, but first they have identical
@@ -279,16 +288,6 @@
-- meet the normal RE rule of separate names for all runtime entities),
-- and second there would be an awful lot of them!
- if Rtp = Standard_Short_Float then
- Pkg := RE_Fat_Short_Float;
- elsif Rtp = Standard_Float then
- Pkg := RE_Fat_Float;
- elsif Rtp = Standard_Long_Float then
- Pkg := RE_Fat_Long_Float;
- else
- Pkg := RE_Fat_Long_Long_Float;
- end if;
-
Fnm :=
Make_Selected_Component (Loc,
Prefix => New_Reference_To (RTE (Pkg), Loc),
@@ -302,7 +301,7 @@
Rewrite (N,
Unchecked_Convert_To (Base_Type (Etype (N)),
Make_Function_Call (Loc,
- Name => Fnm,
+ Name => Fnm,
Parameter_Associations => Args)));
Analyze_And_Resolve (N, Typ);
@@ -318,12 +317,13 @@
procedure Expand_Fpt_Attribute_R (N : Node_Id) is
E1 : constant Node_Id := First (Expressions (N));
- Rtp : constant Entity_Id := Root_Type (Etype (E1));
-
+ Ftp : Entity_Id;
+ Pkg : RE_Id;
begin
+ Find_Fat_Info (Etype (E1), Ftp, Pkg);
Expand_Fpt_Attribute
- (N, Rtp, Attribute_Name (N),
- New_List (Unchecked_Convert_To (Rtp, Relocate_Node (E1))));
+ (N, Pkg, Attribute_Name (N),
+ New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
end Expand_Fpt_Attribute_R;
-----------------------------
@@ -337,14 +337,15 @@
procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
E1 : constant Node_Id := First (Expressions (N));
- Rtp : constant Entity_Id := Root_Type (Etype (E1));
+ Ftp : Entity_Id;
+ Pkg : RE_Id;
E2 : constant Node_Id := Next (E1);
-
begin
+ Find_Fat_Info (Etype (E1), Ftp, Pkg);
Expand_Fpt_Attribute
- (N, Rtp, Attribute_Name (N),
+ (N, Pkg, Attribute_Name (N),
New_List (
- Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
+ Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
end Expand_Fpt_Attribute_RI;
@@ -358,15 +359,16 @@
procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
E1 : constant Node_Id := First (Expressions (N));
- Rtp : constant Entity_Id := Root_Type (Etype (E1));
+ Ftp : Entity_Id;
+ Pkg : RE_Id;
E2 : constant Node_Id := Next (E1);
-
begin
+ Find_Fat_Info (Etype (E1), Ftp, Pkg);
Expand_Fpt_Attribute
- (N, Rtp, Attribute_Name (N),
+ (N, Pkg, Attribute_Name (N),
New_List (
- Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
- Unchecked_Convert_To (Rtp, Relocate_Node (E2))));
+ Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
+ Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
end Expand_Fpt_Attribute_RR;
----------------------------------
@@ -1011,8 +1013,31 @@
when Attribute_Callable => Callable :
begin
- Rewrite (N,
- Build_Call_With_Task (Pref, RTE (RE_Callable)));
+ -- We have an object of a task interface class-wide type as a prefix
+ -- to Callable. Generate:
+
+ -- callable (Pref._disp_get_task_id);
+
+ if Ada_Version >= Ada_05
+ and then Ekind (Etype (Pref)) = E_Class_Wide_Type
+ and then Is_Interface (Etype (Pref))
+ and then Is_Task_Interface (Etype (Pref))
+ then
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Callable), Loc),
+ Parameter_Associations => New_List (
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Copy_Tree (Pref),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
+ else
+ Rewrite (N,
+ Build_Call_With_Task (Pref, RTE (RE_Callable)));
+ end if;
+
Analyze_And_Resolve (N, Standard_Boolean);
end Callable;
@@ -1630,8 +1655,8 @@
-- expands into
- -- Result_Type (System.Fore (Long_Long_Float (Type'First)),
- -- Long_Long_Float (Type'Last))
+ -- Result_Type (System.Fore (Universal_Real (Type'First)),
+ -- Universal_Real (Type'Last))
-- Note that we know that the type is a non-static subtype, or Fore
-- would have itself been computed dynamically in Eval_Attribute.
@@ -1647,12 +1672,12 @@
Name => New_Reference_To (RTE (RE_Fore), Loc),
Parameter_Associations => New_List (
- Convert_To (Standard_Long_Long_Float,
+ Convert_To (Universal_Real,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_First)),
- Convert_To (Standard_Long_Long_Float,
+ Convert_To (Universal_Real,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Last))))));
@@ -2283,6 +2308,17 @@
when Attribute_Machine =>
Expand_Fpt_Attribute_R (N);
+ ----------------------
+ -- Machine_Rounding --
+ ----------------------
+
+ -- Transforms 'Machine_Rounding into a call to the floating-point
+ -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
+ -- type).
+
+ when Attribute_Machine_Rounding =>
+ Expand_Fpt_Attribute_R (N);
+
------------------
-- Machine_Size --
------------------
@@ -2425,7 +2461,7 @@
end if;
- Analyze_And_Resolve (N, Btyp, All_Checks);
+ Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
end Mod_Case;
-----------
@@ -3211,7 +3247,7 @@
Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
return;
- -- For x'Size applied to an object of a class-wide type, transform
+ -- For X'Size applied to an object of a class-wide type, transform
-- X'Size into a call to the primitive operation _Size applied to X.
elsif Is_Class_Wide_Type (Ptyp) then
@@ -3268,8 +3304,8 @@
else
Apply_Universal_Integer_Attribute_Checks (N);
- -- If we have Size applied to a formal parameter, that is a
- -- packed array subtype, then apply size to the actual subtype.
+ -- If Size is applied to a formal parameter that is of a packed
+ -- array subtype, then apply Size to the actual subtype.
if Is_Entity_Name (Pref)
and then Is_Formal (Entity (Pref))
@@ -3284,6 +3320,20 @@
Analyze_And_Resolve (N, Typ);
end if;
+ -- If Size is applied to a dereference of an access to
+ -- unconstrained packed array, GIGI needs to see its
+ -- unconstrained nominal type, but also a hint to the actual
+ -- constrained type.
+
+ if Nkind (Pref) = N_Explicit_Dereference
+ and then Is_Array_Type (Etype (Pref))
+ and then not Is_Constrained (Etype (Pref))
+ and then Is_Packed (Etype (Pref))
+ then
+ Set_Actual_Designated_Subtype (Pref,
+ Get_Actual_Subtype (Pref));
+ end if;
+
return;
end if;
@@ -3590,8 +3640,29 @@
when Attribute_Terminated => Terminated :
begin
- if Restricted_Profile then
+ -- The prefix of Terminated is of a task interface class-wide type.
+ -- Generate:
+
+ -- terminated (Pref._disp_get_task_id);
+
+ if Ada_Version >= Ada_05
+ and then Ekind (Etype (Pref)) = E_Class_Wide_Type
+ and then Is_Interface (Etype (Pref))
+ and then Is_Task_Interface (Etype (Pref))
+ then
Rewrite (N,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Terminated), Loc),
+ Parameter_Associations => New_List (
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Copy_Tree (Pref),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
+
+ elsif Restricted_Profile then
+ Rewrite (N,
Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
else
@@ -3641,8 +3712,27 @@
----------------------
when Attribute_Unchecked_Access =>
- Expand_Access_To_Type (N);
+ -- Ada 2005 (AI-251): If the designated type is an interface, then
+ -- rewrite the referenced object as a conversion to force the
+ -- displacement of the pointer to the secondary dispatch table.
+
+ if Is_Interface (Directly_Designated_Type (Btyp)) then
+ declare
+ Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
+ Conversion : Node_Id;
+ begin
+ Conversion := Convert_To (Typ, New_Copy_Tree (Ref_Object));
+ Rewrite (N, Conversion);
+ Analyze_And_Resolve (N, Typ);
+ end;
+
+ -- Otherwise this is like normal Access without a check
+
+ else
+ Expand_Access_To_Type (N);
+ end if;
+
-----------------
-- UET_Address --
-----------------
@@ -3687,8 +3777,27 @@
-------------------------
when Attribute_Unrestricted_Access =>
- Expand_Access_To_Type (N);
+ -- Ada 2005 (AI-251): If the designated type is an interface, then
+ -- rewrite the referenced object as a conversion to force the
+ -- displacement of the pointer to the secondary dispatch table.
+
+ if Is_Interface (Directly_Designated_Type (Btyp)) then
+ declare
+ Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
+ Conversion : Node_Id;
+ begin
+ Conversion := Convert_To (Typ, New_Copy_Tree (Ref_Object));
+ Rewrite (N, Conversion);
+ Analyze_And_Resolve (N, Typ);
+ end;
+
+ -- Otherwise this is like Access without a check
+
+ else
+ Expand_Access_To_Type (N);
+ end if;
+
---------------
-- VADS_Size --
---------------
@@ -3824,43 +3933,50 @@
if Is_Floating_Point_Type (Ptyp) then
declare
- Rtp : constant Entity_Id := Root_Type (Etype (Pref));
+ Pkg : RE_Id;
+ Ftp : Entity_Id;
begin
-- For vax fpt types, call appropriate routine in special vax
-- floating point unit. We do not have to worry about loads in
-- this case, since these types have no signalling NaN's.
- if Vax_Float (Rtp) then
+ if Vax_Float (Btyp) then
Expand_Vax_Valid (N);
- -- If the floating-point object might be unaligned, we need
- -- to call the special routine Unaligned_Valid, which makes
- -- the needed copy, being careful not to load the value into
- -- any floating-point register. The argument in this case is
- -- obj'Address (see Unchecked_Valid routine in s-fatgen.ads).
+ -- Non VAX float case
- elsif Is_Possibly_Unaligned_Object (Pref) then
- Set_Attribute_Name (N, Name_Unaligned_Valid);
- Expand_Fpt_Attribute
- (N, Rtp, Name_Unaligned_Valid,
- New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Pref),
- Attribute_Name => Name_Address)));
+ else
+ Find_Fat_Info (Etype (Pref), Ftp, Pkg);
- -- In the normal case where we are sure the object is aligned,
- -- we generate a call to Valid, and the argument in this case
- -- is obj'Unrestricted_Access (after converting obj to the
- -- right floating-point type).
+ -- If the floating-point object might be unaligned, we need
+ -- to call the special routine Unaligned_Valid, which makes
+ -- the needed copy, being careful not to load the value into
+ -- any floating-point register. The argument in this case is
+ -- obj'Address (see Unchecked_Valid routine in Fat_Gen).
- else
- Expand_Fpt_Attribute
- (N, Rtp, Name_Valid,
- New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Unchecked_Convert_To (Rtp, Pref),
- Attribute_Name => Name_Unrestricted_Access)));
+ if Is_Possibly_Unaligned_Object (Pref) then
+ Set_Attribute_Name (N, Name_Unaligned_Valid);
+ Expand_Fpt_Attribute
+ (N, Pkg, Name_Unaligned_Valid,
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Pref),
+ Attribute_Name => Name_Address)));
+
+ -- In the normal case where we are sure the object is
+ -- aligned, we generate a call to Valid, and the argument in
+ -- this case is obj'Unrestricted_Access (after converting
+ -- obj to the right floating-point type).
+
+ else
+ Expand_Fpt_Attribute
+ (N, Pkg, Name_Valid,
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Unchecked_Convert_To (Ftp, Pref),
+ Attribute_Name => Name_Unrestricted_Access)));
+ end if;
end if;
-- One more task, we still need a range check. Required
@@ -4488,6 +4604,78 @@
Reason => CE_Overflow_Check_Failed));
end Expand_Pred_Succ;
+ -------------------
+ -- Find_Fat_Info --
+ -------------------
+
+ procedure Find_Fat_Info
+ (T : Entity_Id;
+ Fat_Type : out Entity_Id;
+ Fat_Pkg : out RE_Id)
+ is
+ Btyp : constant Entity_Id := Base_Type (T);
+ Rtyp : constant Entity_Id := Root_Type (T);
+ Digs : constant Nat := UI_To_Int (Digits_Value (Btyp));
+
+ begin
+ -- If the base type is VAX float, then get appropriate VAX float type
+
+ if Vax_Float (Btyp) then
+ case Digs is
+ when 6 =>
+ Fat_Type := RTE (RE_Fat_VAX_F);
+ Fat_Pkg := RE_Attr_VAX_F_Float;
+
+ when 9 =>
+ Fat_Type := RTE (RE_Fat_VAX_D);
+ Fat_Pkg := RE_Attr_VAX_D_Float;
+
+ when 15 =>
+ Fat_Type := RTE (RE_Fat_VAX_G);
+ Fat_Pkg := RE_Attr_VAX_G_Float;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- If root type is VAX float, this is the case where the library has
+ -- been recompiled in VAX float mode, and we have an IEEE float type.
+ -- This is when we use the special IEEE Fat packages.
+
+ elsif Vax_Float (Rtyp) then
+ case Digs is
+ when 6 =>
+ Fat_Type := RTE (RE_Fat_IEEE_Short);
+ Fat_Pkg := RE_Attr_IEEE_Short;
+
+ when 15 =>
+ Fat_Type := RTE (RE_Fat_IEEE_Long);
+ Fat_Pkg := RE_Attr_IEEE_Long;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- If neither the base type nor the root type is VAX_Float then VAX
+ -- float is out of the picture, and we can just use the root type.
+
+ else
+ Fat_Type := Rtyp;
+
+ if Fat_Type = Standard_Short_Float then
+ Fat_Pkg := RE_Attr_Short_Float;
+ elsif Fat_Type = Standard_Float then
+ Fat_Pkg := RE_Attr_Float;
+ elsif Fat_Type = Standard_Long_Float then
+ Fat_Pkg := RE_Attr_Long_Float;
+ elsif Fat_Type = Standard_Long_Long_Float then
+ Fat_Pkg := RE_Attr_Long_Long_Float;
+ else
+ raise Program_Error;
+ end if;
+ end if;
+ end Find_Fat_Info;
+
----------------------------
-- Find_Stream_Subprogram --
----------------------------
Index: sem_disp.adb
===================================================================
--- sem_disp.adb (revision 106884)
+++ sem_disp.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
@@ -550,10 +550,13 @@
if Ada_Version = Ada_05
and then Present (Tagged_Type)
and then Is_Concurrent_Type (Tagged_Type)
- and then not Is_Empty_Elmt_List
- (Abstract_Interfaces
- (Corresponding_Record_Type (Tagged_Type)))
then
+ -- Protect the frontend against previously detected errors
+
+ if not Present (Corresponding_Record_Type (Tagged_Type)) then
+ return;
+ end if;
+
Tagged_Type := Corresponding_Record_Type (Tagged_Type);
end if;
@@ -589,8 +592,8 @@
-- where it can be a dispatching op is when it overrides an operation
-- before the freezing point of the type.
- elsif ((not Is_Package (Scope (Subp)))
- or else In_Package_Body (Scope (Subp)))
+ elsif ((not Is_Package_Or_Generic_Package (Scope (Subp)))
+ or else In_Package_Body (Scope (Subp)))
and then not Has_Dispatching_Parent
then
if not Comes_From_Source (Subp)
@@ -1261,7 +1264,7 @@
Replace_Elmt (Op_Elmt, New_Op);
end if;
- if (not Is_Package (Current_Scope))
+ if (not Is_Package_Or_Generic_Package (Current_Scope))
or else not In_Private_Part (Current_Scope)
then
-- Not a private primitive
Index: Makefile.rtl
===================================================================
--- Makefile.rtl (revision 106884)
+++ Makefile.rtl (working copy)
@@ -391,9 +391,14 @@
s-fatsfl$(objext) \
s-ficobl$(objext) \
s-fileio$(objext) \
+ s-filofl$(objext) \
+ s-fishfl$(objext) \
s-finimp$(objext) \
s-finroo$(objext) \
s-fore$(objext) \
+ s-fvadfl$(objext) \
+ s-fvaffl$(objext) \
+ s-fvagfl$(objext) \
s-geveop$(objext) \
s-htable$(objext) \
s-imgbiu$(objext) \
Index: s-fatflt.ads
===================================================================
--- s-fatflt.ads (revision 106884)
+++ s-fatflt.ads (working copy)
@@ -44,6 +44,6 @@
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
- package Fat_Float is new System.Fat_Gen (Float);
+ package Attr_Float is new System.Fat_Gen (Float);
end System.Fat_Flt;
Index: s-fatlfl.ads
===================================================================
--- s-fatlfl.ads (revision 106884)
+++ s-fatlfl.ads (working copy)
@@ -44,6 +44,6 @@
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
- package Fat_Long_Float is new System.Fat_Gen (Long_Float);
+ package Attr_Long_Float is new System.Fat_Gen (Long_Float);
end System.Fat_LFlt;
Index: s-fatllf.ads
===================================================================
--- s-fatllf.ads (revision 106884)
+++ s-fatllf.ads (working copy)
@@ -44,6 +44,6 @@
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
- package Fat_Long_Long_Float is new System.Fat_Gen (Long_Long_Float);
+ package Attr_Long_Long_Float is new System.Fat_Gen (Long_Long_Float);
end System.Fat_LLF;
Index: s-fatsfl.ads
===================================================================
--- s-fatsfl.ads (revision 106884)
+++ s-fatsfl.ads (working copy)
@@ -44,6 +44,6 @@
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
- package Fat_Short_Float is new System.Fat_Gen (Short_Float);
+ package Attr_Short_Float is new System.Fat_Gen (Short_Float);
end System.Fat_SFlt;
Index: s-filofl.ads
===================================================================
--- s-filofl.ads (revision 0)
+++ s-filofl.ads (revision 0)
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ I E E E _ L O N G _ F L O A T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains an instantiation of the floating-point attribute
+-- runtime routines for IEEE long float. This is used on VMS targest where
+-- we can't just use Long_Float, since this may have been mapped to Vax_Float
+-- using a Float_Representation configuration pragma.
+
+with System.Fat_Gen;
+
+package System.Fat_IEEE_Long_Float is
+ pragma Pure;
+
+ type Fat_IEEE_Long is digits 15;
+ pragma Float_Representation (IEEE_Float, Fat_IEEE_Long);
+
+ -- Note the only entity from this package that is acccessed by Rtsfind
+ -- is the name of the package instantiation. Entities within this package
+ -- (i.e. the individual floating-point attribute routines) are accessed
+ -- by name using selected notation.
+
+ package Attr_IEEE_Long is new System.Fat_Gen (Fat_IEEE_Long);
+
+end System.Fat_IEEE_Long_Float;
Index: s-fishfl.ads
===================================================================
--- s-fishfl.ads (revision 0)
+++ s-fishfl.ads (revision 0)
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ I E E E _ S H O R T _ F L O A T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains an instantiation of the floating-point attribute
+-- runtime routines for IEEE short float. This is used on VMS targest where
+-- we can't just use Float, since this may have been mapped to Vax_Float
+-- using a Float_Representation configuration pragma.
+
+with System.Fat_Gen;
+
+package System.Fat_IEEE_Short_Float is
+ pragma Pure;
+
+ type Fat_IEEE_Short is digits 6;
+ pragma Float_Representation (IEEE_Float, Fat_IEEE_Short);
+
+ -- Note the only entity from this package that is acccessed by Rtsfind
+ -- is the name of the package instantiation. Entities within this package
+ -- (i.e. the individual floating-point attribute routines) are accessed
+ -- by name using selected notation.
+
+ package Attr_IEEE_Short is new System.Fat_Gen (Fat_IEEE_Short);
+
+end System.Fat_IEEE_Short_Float;
Index: s-fvadfl.ads
===================================================================
--- s-fvadfl.ads (revision 0)
+++ s-fvadfl.ads (revision 0)
@@ -0,0 +1,56 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ V A X _ D _ F L O A T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains an instantiation of the floating-point attribute
+-- runtime routines for VAX D-float for use on VMS targets.
+
+with System.Fat_Gen;
+
+package System.Fat_VAX_D_Float is
+ pragma Pure;
+
+ pragma Warnings (Off);
+ -- This unit is normally used only for VMS, but we compile it for other
+ -- targest for the convenience of testing vms code using -gnatdm.
+
+ type Fat_VAX_D is digits 9;
+ pragma Float_Representation (VAX_Float, Fat_VAX_D);
+
+ -- Note the only entity from this package that is acccessed by Rtsfind
+ -- is the name of the package instantiation. Entities within this package
+ -- (i.e. the individual floating-point attribute routines) are accessed
+ -- by name using selected notation.
+
+ package Attr_VAX_D_Float is new System.Fat_Gen (Fat_VAX_D);
+
+end System.Fat_VAX_D_Float;
Index: s-fvaffl.ads
===================================================================
--- s-fvaffl.ads (revision 0)
+++ s-fvaffl.ads (revision 0)
@@ -0,0 +1,56 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ V A X _ F _ F L O A T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains an instantiation of the floating-point attribute
+-- runtime routines for VAX F-float for use on VMS targets.
+
+with System.Fat_Gen;
+
+package System.Fat_VAX_F_Float is
+ pragma Pure;
+
+ pragma Warnings (Off);
+ -- This unit is normally used only for VMS, but we compile it for other
+ -- targest for the convenience of testing vms code using -gnatdm.
+
+ type Fat_VAX_F is digits 6;
+ pragma Float_Representation (VAX_Float, Fat_VAX_F);
+
+ -- Note the only entity from this package that is acccessed by Rtsfind
+ -- is the name of the package instantiation. Entities within this package
+ -- (i.e. the individual floating-point attribute routines) are accessed
+ -- by name using selected notation.
+
+ package Attr_VAX_F_Float is new System.Fat_Gen (Fat_VAX_F);
+
+end System.Fat_VAX_F_Float;
Index: s-fvagfl.ads
===================================================================
--- s-fvagfl.ads (revision 0)
+++ s-fvagfl.ads (revision 0)
@@ -0,0 +1,56 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F A T _ V A X _ G _ F L O A T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2005 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains an instantiation of the floating-point attribute
+-- runtime routines for VAX F-float for use on VMS targets.
+
+with System.Fat_Gen;
+
+package System.Fat_VAX_G_Float is
+ pragma Pure;
+
+ pragma Warnings (Off);
+ -- This unit is normally used only for VMS, but we compile it for other
+ -- targest for the convenience of testing vms code using -gnatdm.
+
+ type Fat_VAX_G is digits 15;
+ pragma Float_Representation (VAX_Float, Fat_VAX_G);
+
+ -- Note the only entity from this package that is acccessed by Rtsfind
+ -- is the name of the package instantiation. Entities within this package
+ -- (i.e. the individual floating-point attribute routines) are accessed
+ -- by name using selected notation.
+
+ package Attr_VAX_G_Float is new System.Fat_Gen (Fat_VAX_G);
+
+end System.Fat_VAX_G_Float;
More information about the Gcc-patches
mailing list