* sem_prag.adb (GNAT_Pragma): Check comes from source.
2011-12-12 Robert Dewar <dewar@adacore.com>
* gnatls.adb: Minor reformatting.
2011-12-12 Javier Miranda <miranda@adacore.com>
* a-tags.ads (Alignment): New TSD field.
(Max_Predef_Prims): Value lowered to 15 (or 9 in case of
configurable runtime) Update documentation of predefined
primitives since Alignment has been removed.
* exp_disp.ads Update documentation of slots of dispatching
primitives.
* exp_disp.adb (Default_Prim_Op_Position): Update slot
values since alignment is no longer a predefined primitive.
(Is_Predefined_Dispatch_Operation): Remove _alignment.
(Is_Predefined_Internal_Operation): Remove _alignment.
(Make_DT): Update static test on the value stored in a-tags.ads
for Max_Predef_Prims; store the value of 'alignment in the TSD.
* exp_atag.ads, exp_atag.adb (Build_Get_Alignment): New subprogram
that retrieves the alignment from the TSD
* exp_util.adb (Build_Allocated_Deallocate_Proc): For deallocation
of class-wide types obtain the value of alignment from the TSD.
* exp_attr.adb (Expand_N_Attribute_Reference): For 'alignment
applied to a class-wide type invoke Build_Get_Alignment to
generate code which retrieves the value of the alignment from
the TSD.
* rtsfind.ads (RE_Alignment): New Ada.Tags entity
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): For tagged
types if the value of the alignment is bigger than the Maximum
alignment then set the value of the alignment to the Maximum
alignment and report a warning.
* exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate
spec of _alignment.
(Predefined_Primitive_Bodies): Do not generate body of _alignment.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@182229
138bc75d-0d04-0410-961f-
82ee72b054a4
+2011-12-12 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb (GNAT_Pragma): Check comes from source.
+
+2011-12-12 Robert Dewar <dewar@adacore.com>
+
+ * gnatls.adb: Minor reformatting.
+
+2011-12-12 Javier Miranda <miranda@adacore.com>
+
+ * a-tags.ads (Alignment): New TSD field.
+ (Max_Predef_Prims): Value lowered to 15 (or 9 in case of
+ configurable runtime) Update documentation of predefined
+ primitives since Alignment has been removed.
+ * exp_disp.ads Update documentation of slots of dispatching
+ primitives.
+ * exp_disp.adb (Default_Prim_Op_Position): Update slot
+ values since alignment is no longer a predefined primitive.
+ (Is_Predefined_Dispatch_Operation): Remove _alignment.
+ (Is_Predefined_Internal_Operation): Remove _alignment.
+ (Make_DT): Update static test on the value stored in a-tags.ads
+ for Max_Predef_Prims; store the value of 'alignment in the TSD.
+ * exp_atag.ads, exp_atag.adb (Build_Get_Alignment): New subprogram
+ that retrieves the alignment from the TSD
+ * exp_util.adb (Build_Allocated_Deallocate_Proc): For deallocation
+ of class-wide types obtain the value of alignment from the TSD.
+ * exp_attr.adb (Expand_N_Attribute_Reference): For 'alignment
+ applied to a class-wide type invoke Build_Get_Alignment to
+ generate code which retrieves the value of the alignment from
+ the TSD.
+ * rtsfind.ads (RE_Alignment): New Ada.Tags entity
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): For tagged
+ types if the value of the alignment is bigger than the Maximum
+ alignment then set the value of the alignment to the Maximum
+ alignment and report a warning.
+ * exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate
+ spec of _alignment.
+ (Predefined_Primitive_Bodies): Do not generate body of _alignment.
+
2011-12-12 Gary Dismukes <dismukes@adacore.com>
* freeze.adb (Freeze_Expression): Allow freezing of static
-- : primitive ops : +-------------------+
-- | pointers | | access level |
-- +--------------------+ +-------------------+
+ -- | alignment |
+ -- +-------------------+
-- | expanded name |
-- +-------------------+
-- | external tag |
-- function return, and class-wide stream I/O, the danger of objects
-- outliving their type declaration can be eliminated (Ada 2005: AI-344)
+ Alignment : Natural;
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag_Ptr;
procedure Unregister_Tag (T : Tag);
-- Remove a particular tag from the external tag hash table
- Max_Predef_Prims : constant Positive := 16;
+ Max_Predef_Prims : constant Positive := 15;
-- Number of reserved slots for the following predefined ada primitives:
--
-- 1. Size
- -- 2. Alignment,
- -- 3. Read
- -- 4. Write
- -- 5. Input
- -- 6. Output
- -- 7. "="
- -- 8. assignment
- -- 9. deep adjust
- -- 10. deep finalize
- -- 11. async select
- -- 12. conditional select
- -- 13. prim_op kind
- -- 14. task_id
- -- 15. dispatching requeue
- -- 16. timed select
+ -- 2. Read
+ -- 3. Write
+ -- 4. Input
+ -- 5. Output
+ -- 6. "="
+ -- 7. assignment
+ -- 8. deep adjust
+ -- 9. deep finalize
+ -- 10. async select
+ -- 11. conditional select
+ -- 12. prim_op kind
+ -- 13. task_id
+ -- 14. dispatching requeue
+ -- 15. timed select
--
-- The compiler checks that the value here is correct
(RTE_Record_Component (RE_Access_Level), Loc));
end Build_Get_Access_Level;
+ -------------------------
+ -- Build_Get_Alignment --
+ -------------------------
+
+ function Build_Get_Alignment
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Build_TSD (Loc,
+ Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
+ Selector_Name =>
+ New_Reference_To
+ (RTE_Record_Component (RE_Alignment), Loc));
+ end Build_Get_Alignment;
+
------------------------------------------
-- Build_Get_Predefined_Prim_Op_Address --
------------------------------------------
--
-- Generates: TSD (Tag).Access_Level
+ function Build_Get_Alignment
+ (Loc : Source_Ptr;
+ Tag_Node : Node_Id) return Node_Id;
+ -- Build code that retrieves the alignment of the tagged type.
+ --
+ -- Generates: TSD (Tag).Alignment
+
procedure Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Position : Uint;
elsif Is_Class_Wide_Type (Ptyp) then
- -- No need to do anything else compiling under restriction
- -- No_Dispatching_Calls. During the semantic analysis we
- -- already notified such violation.
-
- if Restriction_Active (No_Dispatching_Calls) then
- return;
- end if;
-
New_Node :=
- Make_Function_Call (Loc,
- Name => New_Reference_To
- (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
- Parameter_Associations => New_List (Pref));
+ Build_Get_Alignment (Loc,
+ Make_Attribute_Reference (Loc,
+ Prefix => Pref,
+ Attribute_Name => Name_Tag));
if Typ /= Standard_Integer then
-- Dispatching is required in general, since the result of the attribute
-- will vary with the actual object subtype.
--
- -- _alignment provides result of 'Alignment attribute
-- _size provides result of 'Size attribute
-- typSR provides result of 'Read attribute
-- typSW provides result of 'Write attribute
Ret_Type => Standard_Long_Long_Integer));
- -- Spec of _Alignment
-
- Append_To (Res, Predef_Spec_Or_Body (Loc,
- Tag_Typ => Tag_Typ,
- Name => Name_uAlignment,
- Profile => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
- Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
-
- Ret_Type => Standard_Integer));
-
-- Specs for dispatching stream attributes
declare
end loop;
end if;
- -- Body of _Alignment
-
- Decl := Predef_Spec_Or_Body (Loc,
- Tag_Typ => Tag_Typ,
- Name => Name_uAlignment,
- Profile => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
- Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
-
- Ret_Type => Standard_Integer,
- For_Body => True);
-
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc, New_List (
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_X),
- Attribute_Name => Name_Alignment)))));
-
- Append_To (Res, Decl);
-
-- Body of _Size
Decl := Predef_Spec_Or_Body (Loc,
if Chars (E) = Name_uSize then
return Uint_1;
- elsif Chars (E) = Name_uAlignment then
- return Uint_2;
-
elsif TSS_Name = TSS_Stream_Read then
- return Uint_3;
+ return Uint_2;
elsif TSS_Name = TSS_Stream_Write then
- return Uint_4;
+ return Uint_3;
elsif TSS_Name = TSS_Stream_Input then
- return Uint_5;
+ return Uint_4;
elsif TSS_Name = TSS_Stream_Output then
- return Uint_6;
+ return Uint_5;
elsif Chars (E) = Name_Op_Eq then
- return Uint_7;
+ return Uint_6;
elsif Chars (E) = Name_uAssign then
- return Uint_8;
+ return Uint_7;
elsif TSS_Name = TSS_Deep_Adjust then
- return Uint_9;
+ return Uint_8;
elsif TSS_Name = TSS_Deep_Finalize then
- return Uint_10;
+ return Uint_9;
-- In VM targets unconditionally allow obtaining the position associated
-- with predefined interface primitives since in these platforms any
elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
if Chars (E) = Name_uDisp_Asynchronous_Select then
- return Uint_11;
+ return Uint_10;
elsif Chars (E) = Name_uDisp_Conditional_Select then
- return Uint_12;
+ return Uint_11;
elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
- return Uint_13;
+ return Uint_12;
elsif Chars (E) = Name_uDisp_Get_Task_Id then
- return Uint_14;
+ return Uint_13;
elsif Chars (E) = Name_uDisp_Requeue then
- return Uint_15;
+ return Uint_14;
elsif Chars (E) = Name_uDisp_Timed_Select then
- return Uint_16;
+ return Uint_15;
end if;
end if;
TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
.. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
or else TSS_Name = TSS_Stream_Input
(Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
end if;
-- Ensure that the value of Max_Predef_Prims defined in a-tags is
- -- correct. Valid values are 10 under configurable runtime or 16
+ -- correct. Valid values are 9 under configurable runtime or 15
-- with full runtime.
if RTE_Available (RE_Interface_Data) then
- if Max_Predef_Prims /= 16 then
+ if Max_Predef_Prims /= 15 then
Error_Msg_N ("run-time library configuration error", Typ);
return Result;
end if;
else
- if Max_Predef_Prims /= 10 then
+ if Max_Predef_Prims /= 9 then
Error_Msg_N ("run-time library configuration error", Typ);
Error_Msg_CRT ("tagged types", Typ);
return Result;
-- TSD : Type_Specific_Data (I_Depth) :=
-- (Idepth => I_Depth,
-- Access_Level => Type_Access_Level (Typ),
+ -- Alignment => Typ'Alignment,
-- Expanded_Name => Cstring_Ptr!(Exname'Address))
-- External_Tag => Cstring_Ptr!(Exname'Address))
-- HT_Link => HT_Link'Address,
Append_To (TSD_Aggr_List,
Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+ -- Alignment
+
+ -- For CPP types we cannot rely on the value of 'Alignment provided
+ -- by the backend to initialize this TSD field.
+
+ if Convention (Typ) = Convention_CPP
+ or else Is_CPP_Class (Root_Type (Typ))
+ then
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, 0));
+ else
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Alignment));
+ end if;
+
-- Expanded_Name
Append_To (TSD_Aggr_List,
-- type. Constructs of the form Prefix'Size are converted into
-- Prefix._Size.
- -- _Alignment (2) - implementation of the attribute 'Alignment for
- -- any tagged type. Constructs of the form Prefix'Alignment are
- -- converted into Prefix._Alignment.
-
- -- TSS_Stream_Read (3) - implementation of the stream attribute Read
+ -- TSS_Stream_Read (2) - implementation of the stream attribute Read
-- for any tagged type.
- -- TSS_Stream_Write (4) - implementation of the stream attribute Write
+ -- TSS_Stream_Write (3) - implementation of the stream attribute Write
-- for any tagged type.
- -- TSS_Stream_Input (5) - implementation of the stream attribute Input
+ -- TSS_Stream_Input (4) - implementation of the stream attribute Input
-- for any tagged type.
- -- TSS_Stream_Output (6) - implementation of the stream attribute
+ -- TSS_Stream_Output (5) - implementation of the stream attribute
-- Output for any tagged type.
- -- Op_Eq (7) - implementation of the equality operator for any non-
+ -- Op_Eq (6) - implementation of the equality operator for any non-
-- limited tagged type.
- -- _Assign (8) - implementation of the assignment operator for any
+ -- _Assign (7) - implementation of the assignment operator for any
-- non-limited tagged type.
- -- TSS_Deep_Adjust (9) - implementation of the finalization operation
+ -- TSS_Deep_Adjust (8) - implementation of the finalization operation
-- Adjust for any non-limited tagged type.
- -- TSS_Deep_Finalize (10) - implementation of the finalization
+ -- TSS_Deep_Finalize (9) - implementation of the finalization
-- operation Finalize for any non-limited tagged type.
- -- _Disp_Asynchronous_Select (11) - used in the expansion of ATC with
+ -- _Disp_Asynchronous_Select (10) - used in the expansion of ATC with
-- dispatching triggers. Null implementation for limited interfaces,
-- full body generation for types that implement limited interfaces,
-- not generated for the rest of the cases. See Expand_N_Asynchronous_
-- Select in Exp_Ch9 for more information.
- -- _Disp_Conditional_Select (12) - used in the expansion of conditional
+ -- _Disp_Conditional_Select (11) - used in the expansion of conditional
-- selects with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_
-- Conditional_Entry_Call in Exp_Ch9 for more information.
- -- _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion
+ -- _Disp_Get_Prim_Op_Kind (12) - helper routine used in the expansion
-- of ATC with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases.
- -- _Disp_Get_Task_Id (14) - helper routine used in the expansion of
+ -- _Disp_Get_Task_Id (13) - helper routine used in the expansion of
-- Abort, attributes 'Callable and 'Terminated for task interface
-- class-wide types. Full body generation for task types, null
-- implementation for limited interfaces, not generated for the rest
-- of the cases. See Expand_N_Attribute_Reference in Exp_Attr and
-- Expand_N_Abort_Statement in Exp_Ch9 for more information.
- -- _Disp_Requeue (15) - used in the expansion of dispatching requeue
+ -- _Disp_Requeue (14) - used in the expansion of dispatching requeue
-- statements. Null implementation is provided for protected, task
-- and synchronized interfaces. Protected and task types implementing
-- concurrent interfaces receive full bodies. See Expand_N_Requeue_
-- Statement in Exp_Ch9 for more information.
- -- _Disp_Timed_Select (16) - used in the expansion of timed selects
+ -- _Disp_Timed_Select (15) - used in the expansion of timed selects
-- with dispatching triggers. Null implementation for limited
-- interfaces, full body generation for types that implement limited
-- interfaces, not generated for the rest of the cases. See Expand_N_
Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
Append_To (Actuals, New_Reference_To (Size_Id, Loc));
- Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
+
+ if Is_Allocate
+ or else not Is_Class_Wide_Type (Desig_Typ)
+ then
+ Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
+
+ -- For deallocation of class wide types we obtain the value of
+ -- alignment from the Type Specific Record of the deallocated object.
+ -- This is needed because the frontend expansion of class-wide types
+ -- into equivalent types confuses the backend.
+
+ else
+ -- Generate:
+ -- Obj.all'Alignment
+
+ -- ... because 'Alignment applied to class-wide types is expanded
+ -- into the code that reads the value of alignment from the TSD
+ -- (see Expand_N_Attribute_Reference)
+
+ Append_To (Actuals,
+ Unchecked_Convert_To (RTE (RE_Storage_Offset),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
+ Attribute_Name => Name_Alignment)));
+ end if;
-- h) Is_Controlled
if Rts_Full_Path /= null then
- -- Directory name was found on the project path. Look for the
- -- include subdir(s).
+ -- Directory name was found on the project path. Look for the
+ -- include subdirectory(s).
Src_Path := Get_RTS_Search_Dir (Rts_Full_Path.all, Include);
RE_Unbounded_String, -- Ada.Strings.Unbounded
RE_Access_Level, -- Ada.Tags
+ RE_Alignment, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags
RE_Base_Address, -- Ada.Tags
RE_Unbounded_String => Ada_Strings_Unbounded,
RE_Access_Level => Ada_Tags,
+ RE_Alignment => Ada_Tags,
RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags,
RE_Base_Address => Ada_Tags,
-- Alignment attribute definition clause
when Attribute_Alignment => Alignment : declare
- Align : constant Uint := Get_Alignment_Value (Expr);
-
+ Align : constant Uint := Get_Alignment_Value (Expr);
+ Max_Align : constant Uint := UI_From_Int (Maximum_Alignment);
begin
FOnly := True;
elsif Align /= No_Uint then
Set_Has_Alignment_Clause (U_Ent);
- Set_Alignment (U_Ent, Align);
+
+ if Is_Tagged_Type (U_Ent)
+ and then Align > Max_Align
+ then
+ Error_Msg_N
+ ("?alignment for & set to Maximum_Aligment", Nam);
+ Set_Alignment (U_Ent, Max_Align);
+ else
+ Set_Alignment (U_Ent, Align);
+ end if;
-- For an array type, U_Ent is the first subtype. In that case,
-- also set the alignment of the anonymous base type so that
procedure GNAT_Pragma is
begin
- Check_Restriction (No_Implementation_Pragmas, N);
+ -- We need to check the No_Implementation_Pragmas restriction for
+ -- the case of a pragma from source. Note that the case of aspects
+ -- generating corresponding pragmas marks these pragmas as not being
+ -- from source, so this test also catches that case.
+
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Implementation_Pragmas, N);
+ end if;
end GNAT_Pragma;
--------------------------
OSDN Git Service
