OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-11-20  Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb: Minor reformatting.

2014-11-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_util.adb (Make_Subtype_From_Expr): Capture the bounds of
	all index constracts when the expression is of an array type.

2014-11-20  Bob Duff  <duff@adacore.com>

	* s-taskin.ads: Minor comment improvements.

2014-11-20  Bob Duff  <duff@adacore.com>

	* exp_ch9.adb: Minor comment fixes.
	* s-taskin.adb (Initialize): Small simplification: pass System_Domain
	to Initialize_ATCB instead of passing null and then setting the Domain
	to System_Domain. This requires moving the creation of System_Domain
	earlier.
	* s-taprop-linux.adb (Set_Task_Affinity): Only call CPU_SET for
	processors that have a True in the Domain. This is necessary if the
	Domain is not all-True values.

2014-11-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Has_Good_Profile): a) An stream attribute
	for the class-wide type of an interface type is not a primitive
	operation and is not subject to the restrictions of 13.13. (38/3).
	b) A stream operation for an interface type must be a null
	procedure, and it cannot be a function.

From-SVN: r217857
This commit is contained in:
Arnaud Charlet 2014-11-20 15:29:05 +01:00
parent d85badc750
commit d18b1548fa
8 changed files with 149 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/ada/ChangeLog
View File

@ -1,3 +1,35 @@
2014-11-20 Robert Dewar <dewar@adacore.com>
* exp_attr.adb: Minor reformatting.
2014-11-20 Hristian Kirtchev <kirtchev@adacore.com>
* exp_util.adb (Make_Subtype_From_Expr): Capture the bounds of
all index constracts when the expression is of an array type.
2014-11-20 Bob Duff <duff@adacore.com>
* s-taskin.ads: Minor comment improvements.
2014-11-20 Bob Duff <duff@adacore.com>
* exp_ch9.adb: Minor comment fixes.
* s-taskin.adb (Initialize): Small simplification: pass System_Domain
to Initialize_ATCB instead of passing null and then setting the Domain
to System_Domain. This requires moving the creation of System_Domain
earlier.
* s-taprop-linux.adb (Set_Task_Affinity): Only call CPU_SET for
processors that have a True in the Domain. This is necessary if the
Domain is not all-True values.
2014-11-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Has_Good_Profile): a) An stream attribute
for the class-wide type of an interface type is not a primitive
operation and is not subject to the restrictions of 13.13. (38/3).
b) A stream operation for an interface type must be a null
procedure, and it cannot be a function.
2014-11-20 Bob Duff <duff@adacore.com>
* exp_attr.adb (Attribute_Max_Size_In_Storage_Elements):

2
gcc/ada/exp_attr.adb
View File

@ -4232,10 +4232,12 @@ package body Exp_Attr is
-- retrieve the original attribute reference from the expression.
Attr := N;
if Nkind (Attr) = N_Type_Conversion then
Attr := Expression (Attr);
Conversion_Added := True;
end if;
pragma Assert (Nkind (Attr) = N_Attribute_Reference);
-- Heap-allocated controlled objects contain two extra pointers which

6
gcc/ada/exp_ch9.adb
View File

@ -14146,9 +14146,7 @@ package body Exp_Ch9 is
-- present, then the dispatching domain is null. If a rep item is
-- present, then the dispatching domain is taken from the
-- _Dispatching_Domain field of the task value record, which was set
-- from the rep item value. Note that this parameter must not be
-- generated for the restricted profiles since Ravenscar does not
-- allow dispatching domains.
-- from the rep item value.
-- Case where Dispatching_Domain rep item applies: use given value
@ -14162,7 +14160,7 @@ package body Exp_Ch9 is
Selector_Name =>
Make_Identifier (Loc, Name_uDispatching_Domain)));
-- No pragma or aspect Dispatching_Domain apply to the task
-- No pragma or aspect Dispatching_Domain applies to the task
else
Append_To (Args, Make_Null (Loc));

83
gcc/ada/exp_util.adb
View File

@ -6399,22 +6399,24 @@ package body Exp_Util is
(E : Node_Id;
Unc_Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (E);
List_Constr : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (E);
D : Entity_Id;
Full_Subtyp : Entity_Id;
Priv_Subtyp : Entity_Id;
Utyp : Entity_Id;
Full_Exp : Node_Id;
Full_Exp : Node_Id;
Full_Subtyp : Entity_Id;
High_Bound : Entity_Id;
Index_Typ : Entity_Id;
Low_Bound : Entity_Id;
Priv_Subtyp : Entity_Id;
Utyp : Entity_Id;
begin
if Is_Private_Type (Unc_Typ)
and then Has_Unknown_Discriminants (Unc_Typ)
then
-- Prepare the subtype completion, Go to base type to
-- find underlying type, because the type may be a generic
-- actual or an explicit subtype.
-- Prepare the subtype completion. Use the base type to find the
-- underlying type because the type may be a generic actual or an
-- explicit subtype.
Utyp := Underlying_Type (Base_Type (Unc_Typ));
Full_Subtyp := Make_Temporary (Loc, 'C');
@ -6451,22 +6453,67 @@ package body Exp_Util is
return New_Occurrence_Of (Priv_Subtyp, Loc);
elsif Is_Array_Type (Unc_Typ) then
Index_Typ := First_Index (Unc_Typ);
for J in 1 .. Number_Dimensions (Unc_Typ) loop
Append_To (List_Constr,
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr_No_Checks (E),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J))),
High_Bound =>
-- Capture the bounds of each index constraint in case the context
-- is an object declaration of an unconstrained type initialized
-- by a function call:
-- Obj : Unconstr_Typ := Func_Call;
-- This scenario requires secondary scope management and the index
-- constraint cannot depend on the temporary used to capture the
-- result of the function call.
-- SS_Mark;
-- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
-- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
-- Obj : S := Temp.all;
-- SS_Release; -- Temp is gone at this point, bounds of S are
-- -- non existent.
-- The bounds are kept as variables rather than constants because
-- this prevents spurious optimizations down the line.
-- Generate:
-- Low_Bound : Base_Type (Index_Typ) := E'First (J);
Low_Bound := Make_Temporary (Loc, 'B');
Insert_Action (E,
Make_Object_Declaration (Loc,
Defining_Identifier => Low_Bound,
Object_Definition =>
New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr_No_Checks (E),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J)))));
-- Generate:
-- High_Bound : Base_Type (Index_Typ) := E'Last (J);
High_Bound := Make_Temporary (Loc, 'B');
Insert_Action (E,
Make_Object_Declaration (Loc,
Defining_Identifier => High_Bound,
Object_Definition =>
New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr_No_Checks (E),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J)))));
Append_To (List_Constr,
Make_Range (Loc,
Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
High_Bound => New_Occurrence_Of (High_Bound, Loc)));
Index_Typ := Next_Index (Index_Typ);
end loop;
elsif Is_Class_Wide_Type (Unc_Typ) then

4
gcc/ada/s-taprop-linux.adb
View File

@ -1516,7 +1516,9 @@ package body System.Task_Primitives.Operations is
System.OS_Interface.CPU_ZERO (Size, CPU_Set);
for Proc in T.Common.Domain'Range loop
System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
if T.Common.Domain (Proc) then
System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
end if;
end loop;
end if;

36
gcc/ada/s-taskin.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -205,18 +205,6 @@ package body System.Tasking is
then System.Multiprocessors.Not_A_Specific_CPU
else System.Multiprocessors.CPU_Range (Main_CPU));
T := STPO.New_ATCB (0);
Initialize_ATCB
(null, null, Null_Address, Null_Task, null, Base_Priority, Base_CPU,
null, Task_Info.Unspecified_Task_Info, 0, T, Success);
pragma Assert (Success);
STPO.Initialize (T);
STPO.Set_Priority (T, T.Common.Base_Priority);
T.Common.State := Runnable;
T.Common.Task_Image_Len := Main_Task_Image'Length;
T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image;
-- At program start-up the environment task is allocated to the default
-- system dispatching domain.
-- Make sure that the processors which are not available are not taken
@ -228,7 +216,27 @@ package body System.Tasking is
(Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs =>
True);
T.Common.Domain := System_Domain;
T := STPO.New_ATCB (0);
Initialize_ATCB
(Self_ID => null,
Task_Entry_Point => null,
Task_Arg => Null_Address,
Parent => Null_Task,
Elaborated => null,
Base_Priority => Base_Priority,
Base_CPU => Base_CPU,
Domain => System_Domain,
Task_Info => Task_Info.Unspecified_Task_Info,
Stack_Size => 0,
T => T,
Success => Success);
pragma Assert (Success);
STPO.Initialize (T);
STPO.Set_Priority (T, T.Common.Base_Priority);
T.Common.State := Runnable;
T.Common.Task_Image_Len := Main_Task_Image'Length;
T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image;
Dispatching_Domain_Tasks :=
new Array_Allocated_Tasks'

8
gcc/ada/s-taskin.ads
View File

@ -1178,9 +1178,11 @@ package System.Tasking is
Stack_Size : System.Parameters.Size_Type;
T : Task_Id;
Success : out Boolean);
-- Initialize fields of a TCB and link into global TCB structures Call
-- this only with abort deferred and holding RTS_Lock. Need more
-- documentation, mention T, and describe Success ???
-- Initialize fields of the TCB for task T, and link into global TCB
-- structures. Call this only with abort deferred and holding
-- RTS_Lock. Self_ID is the calling task (normally the activator of
-- T). Success is set to indicate whether the TCB was successfully
-- initialized. Need more documentation ???
private

25
gcc/ada/sem_ch13.adb
View File

@ -3550,10 +3550,19 @@ package body Sem_Ch13 is
end if;
-- Verify that the prefix of the attribute and the local name for
-- the type of the formal match.
-- the type of the formal match, or one is the class-wide of the
-- other, in the case of a class-wide stream operation.
if Base_Type (Typ) /= Base_Type (Ent)
or else Present (Next_Formal (F))
if Base_Type (Typ) = Base_Type (Ent)
or else (Is_Class_Wide_Type (Typ)
and then Typ = Class_Wide_Type (Base_Type (Ent)))
then
null;
else
return False;
end if;
if Present ((Next_Formal (F)))
then
return False;
@ -3635,12 +3644,14 @@ package body Sem_Ch13 is
-- procedure (RM 13.13.2 (38/3)).
elsif Is_Interface (U_Ent)
and then not Is_Class_Wide_Type (U_Ent)
and then not Inside_A_Generic
and then Ekind (Subp) = E_Procedure
and then
not Null_Present
(Specification
(Unit_Declaration_Node (Ultimate_Alias (Subp))))
(Ekind (Subp) = E_Function
or else
not Null_Present
(Specification
(Unit_Declaration_Node (Ultimate_Alias (Subp)))))
then
Error_Msg_N
("stream subprogram for interface type "