+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):
-- 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
-- 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
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));
(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');
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 =>
+
+ -- 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),
+ Prefix => Duplicate_Subexpr_No_Checks (E),
Attribute_Name => Name_First,
- Expressions => New_List (
- Make_Integer_Literal (Loc, J))),
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, J)))));
+
+ -- Generate:
+ -- High_Bound : Base_Type (Index_Typ) := E'Last (J);
- High_Bound =>
+ 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
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;
-- --
-- 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- --
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
(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'
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
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;
-- 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 "
projects / gcc.git / commitdiff