+2014-11-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch3.adb (Build_Initialization_Call): Reimplement the
+ circuitry which extraacts the [underlying] full view of a
+ private type to handle a case where the private type acts as a
+ generic actual.
+ * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Inherit the
+ loop label form the original loop regardless of whether it came
+ from source.
+ * sem_attr.adb (Analyze_Attribute): When taking 'Access of an
+ expression function with a generated body that has not been
+ analyzed yet, analyze the body to freeze the expression.
+ * sem_util.adb (Set_Public_Status_Of): New routine.
+ (Transfer_Entities): Handle the case where a private type with
+ an internally generated full view is being transfered and update
+ its full view.
+
+2014-11-20 Vincent Celier <celier@adacore.com>
+
+ * prj-nmsc.adb (Check_Object): If a unit is in a multi-source
+ file, its object file is never the same as any other unit.
+
+2014-11-20 Bob Duff <duff@adacore.com>
+
+ * s-taskin.adb (Initialize_ATCB): Take into
+ account the fact that the domain of the activator can be null
+ if we're initializing a foreign task.
+
2014-11-20 Robert Dewar <dewar@adacore.com>
* sem_ch12.adb: Minor reformatting.
Discr : Entity_Id;
First_Arg : Node_Id;
Full_Init_Type : Entity_Id;
- Full_Type : Entity_Id := Typ;
+ Full_Type : Entity_Id;
Init_Type : Entity_Id;
Proc : Entity_Id;
return Empty_List;
end if;
- -- Go to full view or underlying full view if private type. In the case
- -- of successive private derivations, this can require two steps.
+ Full_Type := Typ;
- if Is_Private_Type (Full_Type)
- and then Present (Full_View (Full_Type))
- then
- Full_Type := Full_View (Full_Type);
- end if;
+ -- Use the [underlying] full view when dealing with a private type. This
+ -- may require several steps depending on derivations.
- if Is_Private_Type (Full_Type)
- and then Present (Underlying_Full_View (Full_Type))
- then
- Full_Type := Underlying_Full_View (Full_Type);
- end if;
+ loop
+ if Is_Private_Type (Full_Type) then
+ if Present (Full_View (Full_Type)) then
+ Full_Type := Full_View (Full_Type);
+
+ elsif Present (Underlying_Full_View (Full_Type)) then
+ Full_Type := Underlying_Full_View (Full_Type);
+
+ -- When a private type acts as a generic actual and lacks a full
+ -- view, use the base type.
+
+ elsif Is_Generic_Actual_Type (Full_Type) then
+ Full_Type := Base_Type (Full_Type);
+
+ -- The loop has recovered the [underlying] full view, stop the
+ -- traversal.
+
+ else
+ exit;
+ end if;
+
+ -- The type is not private, nothing to do
+
+ else
+ exit;
+ end if;
+ end loop;
-- If Typ is derived, the procedure is the initialization procedure for
-- the root type. Wrap the argument in an conversion to make it type
end loop;
end if;
- -- If original loop has a source name, preserve it so it can be
- -- recognized by an exit statement in the body of the rewritten loop.
- -- This only concerns source names: the generated name of an anonymous
- -- loop will be create again during the subsequent analysis below.
+ -- Inherit the loop identifier from the original loop. This ensures that
+ -- the scope stack is consistent after the rewriting.
- if Present (Identifier (N))
- and then Comes_From_Source (Identifier (N))
- then
+ if Present (Identifier (N)) then
Set_Identifier (Core_Loop, Relocate_Node (Identifier (N)));
end if;
Error_Msg_Name_1 := Lang_Index.Display_Name;
Error_Msg
(Data.Flags,
- "?no compiler specified for language %%" &
+ "?\no compiler specified for language %%" &
", ignoring all its sources",
No_Location, Project);
if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
Error_Msg
(Data.Flags,
- "Spec_Suffix not specified for " &
+ "\Spec_Suffix not specified for " &
Get_Name_String (Lang_Index.Name),
No_Location, Project);
end if;
if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
Error_Msg
(Data.Flags,
- "Body_Suffix not specified for " &
+ "\Body_Suffix not specified for " &
Get_Name_String (Lang_Index.Name),
No_Location, Project);
end if;
Error_Msg_Name_1 := Lang_Index.Display_Name;
Error_Msg
(Data.Flags,
- "no suffixes specified for %%",
+ "\no suffixes specified for %%",
No_Location, Project);
end if;
end if;
if Switches /= No_Array_Element then
Error_Msg
(Data.Flags,
- "?Linker switches not taken into account in library " &
+ "?\Linker switches not taken into account in library " &
"projects",
No_Location, Project);
end if;
Error_Msg_Name_2 := Source.Unit.Name;
Error_Or_Warning
(Data.Flags, Data.Flags.Missing_Source_Files,
- "source file %% for unit %% not found",
+ "\source file %% for unit %% not found",
No_Location, Project.Project);
end if;
end if;
Error_Msg_File_1 := Source.File;
Error_Msg
(Data.Flags,
- "{ cannot be both excluded and an exception file name",
+ "\{ cannot be both excluded and an exception file name",
No_Location, Project.Project);
end if;
if Source /= No_Source
and then Source.Replaced_By = No_Source
and then Source.Path /= Src.Path
+ and then Source.Index = 0
+ and then Src.Index = 0
and then Is_Extending (Src.Project, Source.Project)
then
Error_Msg_File_1 := Src.File;
Error_Msg_File_2 := Source.File;
Error_Msg
(Data.Flags,
- "{ and { have the same object file name",
+ "\{ and { have the same object file name",
No_Location, Project.Project);
else
T.Common.Base_Priority := Base_Priority;
T.Common.Base_CPU := Base_CPU;
- -- The Domain defaults to that of the activator
-
- T.Common.Domain :=
- (if Domain = null then Self_ID.Common.Domain else Domain);
+ -- The Domain defaults to that of the activator. But that can be null in
+ -- the case of foreign threads (see Register_Foreign_Thread), in which
+ -- case we default to the System_Domain.
+
+ if Domain /= null then
+ T.Common.Domain := Domain;
+ elsif Self_ID.Common.Domain /= null then
+ T.Common.Domain := Self_ID.Common.Domain;
+ else
+ T.Common.Domain := System_Domain;
+ end if;
pragma Assert (T.Common.Domain /= null);
T.Common.Current_Priority := 0;
Scop : constant Entity_Id := Scope (Subp_Id);
Subp_Decl : constant Node_Id :=
Unit_Declaration_Node (Subp_Id);
-
- Flag_Id : Entity_Id;
- HSS : Node_Id;
- Stmt : Node_Id;
+ Flag_Id : Entity_Id;
+ Subp_Body : Node_Id;
-- If the access has been taken and the body of the subprogram
-- has not been see yet, indirect calls must be protected with
-- generated body is immediately analyzed and the expression
-- is automatically frozen.
- if Ekind (Subp_Id) = E_Function
- and then Nkind (Subp_Decl) = N_Subprogram_Declaration
- and then Nkind (Original_Node (Subp_Decl)) =
- N_Expression_Function
+ if Is_Expression_Function (Subp_Id)
and then Present (Corresponding_Body (Subp_Decl))
- and then not Analyzed (Corresponding_Body (Subp_Decl))
then
- HSS :=
- Handled_Statement_Sequence
- (Unit_Declaration_Node
- (Corresponding_Body (Subp_Decl)));
+ Subp_Body :=
+ Unit_Declaration_Node (Corresponding_Body (Subp_Decl));
- if Present (HSS) then
- Stmt := First (Statements (HSS));
+ -- Analyze the body of the expression function to freeze
+ -- the expression. This takes care of the case where the
+ -- 'Access is part of dispatch table initialization and
+ -- the generated body of the expression function has not
+ -- been analyzed yet.
- if Nkind (Stmt) = N_Simple_Return_Statement then
- Freeze_Expression (Expression (Stmt));
- end if;
+ if not Analyzed (Subp_Body) then
+ Analyze (Subp_Body);
end if;
end if;
end;
-----------------------
procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
- Ent : Entity_Id := First_Entity (From);
+ procedure Set_Public_Status_Of (Id : Entity_Id);
+ -- Set the Is_Public attribute of arbitrary entity Id by calling routine
+ -- Set_Public_Status. If successfull and Id denotes a record type, set
+ -- the Is_Public attribute of its fields.
+
+ --------------------------
+ -- Set_Public_Status_Of --
+ --------------------------
+
+ procedure Set_Public_Status_Of (Id : Entity_Id) is
+ Field : Entity_Id;
+
+ begin
+ if not Is_Public (Id) then
+ Set_Public_Status (Id);
+
+ -- When the input entity is a public record type, ensure that all
+ -- its internal fields are also exposed to the linker. The fields
+ -- of a class-wide type are never made public.
+
+ if Is_Public (Id)
+ and then Is_Record_Type (Id)
+ and then not Is_Class_Wide_Type (Id)
+ then
+ Field := First_Entity (Id);
+ while Present (Field) loop
+ Set_Is_Public (Field);
+ Next_Entity (Field);
+ end loop;
+ end if;
+ end if;
+ end Set_Public_Status_Of;
+
+ -- Local variables
+
+ Full_Id : Entity_Id;
+ Id : Entity_Id;
+
+ -- Start of processing for Transfer_Entities
begin
- if No (Ent) then
- return;
- end if;
+ Id := First_Entity (From);
- if (Last_Entity (To)) = Empty then
- Set_First_Entity (To, Ent);
- else
- Set_Next_Entity (Last_Entity (To), Ent);
- end if;
+ if Present (Id) then
- Set_Last_Entity (To, Last_Entity (From));
+ -- Merge the entity chain of the source scope with that of the
+ -- destination scope.
- while Present (Ent) loop
- Set_Scope (Ent, To);
+ if Present (Last_Entity (To)) then
+ Set_Next_Entity (Last_Entity (To), Id);
+ else
+ Set_First_Entity (To, Id);
+ end if;
- if not Is_Public (Ent) then
- Set_Public_Status (Ent);
+ Set_Last_Entity (To, Last_Entity (From));
- if Is_Public (Ent) and then Ekind (Ent) = E_Record_Subtype then
+ -- Inspect the entities of the source scope and update their Scope
+ -- attribute.
- -- The components of the propagated Itype must also be public
+ while Present (Id) loop
+ Set_Scope (Id, To);
+ Set_Public_Status_Of (Id);
- declare
- Comp : Entity_Id;
- begin
- Comp := First_Entity (Ent);
- while Present (Comp) loop
- Set_Is_Public (Comp);
- Next_Entity (Comp);
- end loop;
- end;
+ -- Handle an internally generated full view for a private type
+
+ if Is_Private_Type (Id)
+ and then Present (Full_View (Id))
+ and then Is_Itype (Full_View (Id))
+ then
+ Full_Id := Full_View (Id);
+
+ Set_Scope (Full_Id, To);
+ Set_Public_Status_Of (Full_Id);
end if;
- end if;
- Next_Entity (Ent);
- end loop;
+ Next_Entity (Id);
+ end loop;
- Set_First_Entity (From, Empty);
- Set_Last_Entity (From, Empty);
+ Set_First_Entity (From, Empty);
+ Set_Last_Entity (From, Empty);
+ end if;
end Transfer_Entities;
-----------------------
projects / gcc.git / commitdiff