+2017-09-08 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_util.adb (Copy_Node_With_Replacement):
+ Update the Renamed_Object field of a replicated object renaming
+ declaration.
+
+2017-09-08 Patrick Bernardi <bernardi@adacore.com>
+
+ * exp_ch9.adb (Is_Pure_Barrier): Allow type
+ conversions and components of objects. Simplified the detection
+ of the Count attribute by identifying the corresponding run-time
+ calls.
+
+2017-09-08 Yannick Moy <moy@adacore.com>
+
+ * exp_ch9.adb, exp_disp.adb, repinfo.adb, sem_ch12.adb, sem_dim.adb,
+ sem_type.adb, sinfo.ads: Minor reformatting.
+
+2017-09-08 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Has_Incomplete_Compoent): New predicate, subsidiary
+ of Freeze_Profile, used to inhibit the freezing of the profile
+ of an expression function declared within a nested package, when
+ some type in the profile depends on a private type declared in
+ an enclosing package.
+
+2017-09-08 Bob Duff <duff@adacore.com>
+
+ * gnat1drv.adb (Gnat1drv): Do not set the Force_ALI_Tree_File flag in
+ the subunit case. It's still OK to set it in the "missing subunits"
+ case, because that won't cause the obsolete .ali files that cause
+ confusion.
+
+2017-09-08 Bob Duff <duff@adacore.com>
+
+ * sinput-l.adb: Remove unused "with Unchecked_Conversion;". It's
+ unclear why this didn't cause a warning.
+ * a-uncdea.ads, a-unccon.ads: Add "Ada." to names in the
+ pragmas. It's unclear why this didn't cause an error.
+
2017-09-08 Hristian Kirtchev <kirtchev@adacore.com>
* exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration):
function Ada.Unchecked_Conversion (S : Source) return Target;
-pragma No_Elaboration_Code_All (Unchecked_Conversion);
-pragma Pure (Unchecked_Conversion);
-pragma Import (Intrinsic, Unchecked_Conversion);
+pragma No_Elaboration_Code_All (Ada.Unchecked_Conversion);
+pragma Pure (Ada.Unchecked_Conversion);
+pragma Import (Intrinsic, Ada.Unchecked_Conversion);
procedure Ada.Unchecked_Deallocation (X : in out Name);
pragma Preelaborate (Unchecked_Deallocation);
-pragma Import (Intrinsic, Unchecked_Deallocation);
+pragma Import (Intrinsic, Ada.Unchecked_Deallocation);
Renamed : Node_Id;
begin
- -- Check for case of _object.all.field (note that the explicit
- -- dereference gets inserted by analyze/expand of _object.field).
+ -- Check if the name is a component of the protected object. If
+ -- the expander is active, the component has been transformed into
+ -- a renaming of _object.all.component.
if Expander_Active then
Renamed := Renamed_Object (Entity (N));
and then Nkind (Renamed) = N_Selected_Component
and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
else
- return Scope (Entity (N)) = Current_Scope;
+ return Is_Protected_Component (Entity (N));
end if;
end Is_Simple_Barrier_Name;
---------------------
function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
- function Is_Count_Attribute (N : Node_Id) return Boolean;
- -- Check whether N is part of an expansion of the Count attribute.
- -- Return True if N represents the expanded function call.
-
- ------------------------
- -- Is_Count_Attribute --
- ------------------------
-
- function Is_Count_Attribute (N : Node_Id) return Boolean is
- begin
- return
- Nkind (N) = N_Function_Call
- and then Present (Original_Node (N))
- and then Nkind (Original_Node (N)) = N_Attribute_Reference
- and then Attribute_Name (Original_Node (N)) = Name_Count;
- end Is_Count_Attribute;
-
- -- Start of processing for Is_Pure_Barrier
-
begin
case Nkind (N) is
when N_Expanded_Name
=>
if No (Entity (N)) then
return Abandon;
- end if;
- if Present (Parent (N))
- and then Is_Count_Attribute (Parent (N))
- then
+ elsif Is_Universal_Numeric_Type (Entity (N)) then
return OK;
end if;
=>
return OK;
- when E_Component
- | E_Variable
- =>
- -- A variable in the protected type is expanded as a
- -- component.
+ when E_Component =>
+ return OK;
+ when E_Variable =>
if Is_Simple_Barrier_Name (N) then
return OK;
end if;
+ when E_Function =>
+
+ -- The count attribute has been transformed into run-time
+ -- calls.
+
+ if Is_RTE (Entity (N), RE_Protected_Count)
+ or else Is_RTE (Entity (N), RE_Protected_Count_Entry)
+ then
+ return OK;
+ end if;
+
when others =>
null;
end case;
when N_Function_Call =>
- if Is_Count_Attribute (N) then
- return OK;
- end if;
+
+ -- Function call checks are carried out as part of the analysis
+ -- of the function call name.
+
+ return OK;
when N_Character_Literal
| N_Integer_Literal
when N_Short_Circuit =>
return OK;
+ when N_Indexed_Component
+ | N_Selected_Component
+ =>
+ if not Is_Access_Type (Etype (Prefix (N))) then
+ return OK;
+ end if;
+
+ when N_Type_Conversion =>
+
+ -- Conversions to Universal_Integer will not raise constraint
+ -- errors.
+
+ if Cannot_Raise_Constraint_Error (N)
+ or else Etype (N) = Universal_Integer
+ then
+ return OK;
+ end if;
+
+ when N_Unchecked_Type_Conversion =>
+ return OK;
+
when others =>
null;
end case;
-- Retrieve the ultimate alias of the primitive for proper
-- handling of renamings and eliminated primitives.
- E := Ultimate_Alias (Prim);
+ E := Ultimate_Alias (Prim);
-- If the alias is not a primitive operation then Prim does
-- not rename another primitive, but rather an operation
then
declare
Par_Type : constant Entity_Id :=
- Find_Dispatching_Type (Alias (Prim));
+ Find_Dispatching_Type (Alias (Prim));
+
begin
if Present (Par_Type)
and then Par_Type /= Typ
R_Type : Entity_Id;
Warn_Node : Node_Id;
+ function Has_Incomplete_Component (T : Entity_Id) return Boolean;
+ -- If a type includes a private component from an enclosing scope
+ -- it cannot be frozen yet. This can happen in a package nested
+ -- within another, when freezing an expression function whose
+ -- profile depends on a type in some outer scope. Those types will
+ -- be frozen at a later time in the enclosing unit.
+
+ ------------------------------
+ -- Has_Incomplete_Component --
+ ------------------------------
+
+ function Has_Incomplete_Component (T : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+ Comp_Typ : Entity_Id;
+
+ begin
+ if Nkind (N) /= N_Subprogram_Body
+ or else not Was_Expression_Function (N)
+ then
+ return False;
+
+ elsif In_Instance then
+ return False;
+
+ elsif Is_Record_Type (T) then
+ Comp := First_Entity (T);
+
+ while Present (Comp) loop
+ Comp_Typ := Etype (Comp);
+ if Ekind_In (Comp, E_Component, E_Discriminant)
+ and then Is_Private_Type (Comp_Typ)
+ and then No (Full_View (Comp_Typ))
+ and then In_Open_Scopes (Scope (Comp_Typ))
+ and then Scope (Comp_Typ) /= Current_Scope
+ then
+ return True;
+ end if;
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ return False;
+
+ elsif Is_Array_Type (T) then
+ Comp_Typ := Component_Type (T);
+ return Is_Private_Type (Comp_Typ)
+ and then No (Full_View (Comp_Typ))
+ and then In_Open_Scopes (Scope (Comp_Typ))
+ and then Scope (Comp_Typ) /= Current_Scope;
+
+ else
+ return False;
+ end if;
+ end Has_Incomplete_Component;
+
begin
-- Loop through formals
Set_Etype (Formal, F_Type);
end if;
+ if Has_Incomplete_Component (F_Type) then
+ Set_Is_Frozen (E, False);
+ Result := No_List;
+ return False;
+ end if;
+
if not From_Limited_With (F_Type) then
Freeze_And_Append (F_Type, N, Result);
end if;
Write_Str (" (subunit)");
Write_Eol;
- -- Force generation of ALI file, for backward compatibility
-
- Opt.Force_ALI_Tree_File := True;
+ -- Do not generate an ALI file in this case, because it would
+ -- become obsolete when the parent is compiled, and thus
+ -- confuse tools such as gnatfind.
elsif Main_Unit_Kind = N_Subprogram_Declaration then
Write_Str (" (subprogram spec)");
Cfbit := Component_Bit_Offset (Comp);
if Rep_Not_Constant (Cfbit) then
+
-- If the record is not packed, then we know that all fields
-- whose position is not specified have a starting normalized
-- bit position of zero.
-- only uses them to elaborate entities in a package
-- body.
- declare
+ Explicit_Freeze_Check : declare
Actual : constant Entity_Id := Entity (Match);
Needs_Freezing : Boolean;
--------------------------
procedure Check_Generic_Parent is
- Par : Entity_Id;
+ Par : Entity_Id;
+
begin
- if Nkind (Parent (Actual)) = N_Package_Specification
+ if Nkind (Parent (Actual)) =
+ N_Package_Specification
then
Par := Scope (Generic_Parent (Parent (Actual)));
+
if Is_Generic_Instance (Par)
and then Scope (Par) = Current_Scope
- and then (No (Freeze_Node (Par))
- or else
- not Is_List_Member (Freeze_Node (Par)))
+ and then
+ (No (Freeze_Node (Par))
+ or else
+ not Is_List_Member (Freeze_Node (Par)))
then
Set_Has_Delayed_Freeze (Par);
Append_Elmt (Par, Actuals_To_Freeze);
end if;
end Check_Generic_Parent;
+ -- Start of processing for Explicit_Freeze_Check
+
begin
if not Expander_Active
or else not Has_Completion (Actual)
or else Is_Frozen (Actual)
or else
(Present (Renamed_Entity (Actual))
- and then not
- In_Same_Source_Unit
- (I_Node, (Renamed_Entity (Actual))))
+ and then
+ not In_Same_Source_Unit
+ (I_Node, (Renamed_Entity (Actual))))
then
null;
Append_Elmt (Actual, Actuals_To_Freeze);
end if;
end if;
- end;
+ end Explicit_Freeze_Check;
end if;
-- For use type and use package appearing in the generic part,
and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration,
N_Package_Declaration)
or else (Gen_Unit = Body_Unit
- and then True_Sloc (N, Act_Unit)
- < Sloc (Orig_Body)))
+ and then True_Sloc (N, Act_Unit) <
+ Sloc (Orig_Body)))
and then Is_In_Main_Unit (Original_Node (Gen_Unit))
and then In_Same_Scope (Gen_Id, Act_Id));
if Expander_Active
and then (No (Freeze_Node (Act_Id))
- or else not Is_List_Member (Freeze_Node (Act_Id)))
+ or else not Is_List_Member (Freeze_Node (Act_Id)))
then
Ensure_Freeze_Node (Act_Id);
F_Node := Freeze_Node (Act_Id);
OK_For_Dimension : constant array (Node_Kind) of Boolean :=
(N_Attribute_Reference => True,
N_Case_Expression => True,
- N_If_Expression => True,
N_Expanded_Name => True,
N_Explicit_Dereference => True,
N_Defining_Identifier => True,
N_Function_Call => True,
N_Identifier => True,
+ N_If_Expression => True,
N_Indexed_Component => True,
N_Integer_Literal => True,
N_Op_Abs => True,
when N_Binary_Op =>
Analyze_Dimension_Binary_Op (N);
+ when N_Case_Expression =>
+ Analyze_Dimension_Case_Expression (N);
+
when N_Component_Declaration =>
Analyze_Dimension_Component_Declaration (N);
=>
Analyze_Dimension_Has_Etype (N);
- when N_Case_Expression =>
- Analyze_Dimension_Case_Expression (N);
-
- when N_If_Expression =>
- Analyze_Dimension_If_Expression (N);
-
- -- In the presence of a repaired syntax error, an identifier
- -- may be introduced without a usable type.
+ -- In the presence of a repaired syntax error, an identifier may be
+ -- introduced without a usable type.
when N_Identifier =>
if Present (Etype (N)) then
Analyze_Dimension_Has_Etype (N);
end if;
+ when N_If_Expression =>
+ Analyze_Dimension_If_Expression (N);
+
when N_Number_Declaration =>
Analyze_Dimension_Number_Declaration (N);
---------------------------------------
procedure Analyze_Dimension_Case_Expression (N : Node_Id) is
+ Frst : constant Node_Id := First (Alternatives (N));
+ Frst_Expr : constant Node_Id := Expression (Frst);
+ Dims : constant Dimension_Type := Dimensions_Of (Frst_Expr);
+
Alt : Node_Id;
- Frst : constant Node_Id := First (Alternatives (N));
- Dims : constant Dimension_Type := Dimensions_Of (Expression (Frst));
+
begin
Alt := Next (Frst);
while Present (Alt) loop
Next (Alt);
end loop;
- Copy_Dimensions (Expression (Frst), N);
+
+ Copy_Dimensions (Frst_Expr, N);
end Analyze_Dimension_Case_Expression;
---------------------------------------------
procedure Analyze_Dimension_If_Expression (N : Node_Id) is
Then_Expr : constant Node_Id := Next (First (Expressions (N)));
Else_Expr : constant Node_Id := Next (Then_Expr);
+
begin
if Dimensions_Of (Then_Expr) /= Dimensions_Of (Else_Expr) then
Error_Msg_N ("dimensions mismatch in conditional expression", N);
-- Continue climbing
else
- -- Use the full-view of private types (if allowed).
- -- Guard against infinite loops when full view has same
- -- type as parent, as can happen with interface extensions,
+ -- Use the full-view of private types (if allowed). Guard
+ -- against infinite loops when full view has same type as
+ -- parent, as can happen with interface extensions.
if Use_Full_View
and then Is_Private_Type (Par)
(New_Node, Default_Node.Comes_From_Source);
end if;
- -- If the node is a call and has named associations, set the
- -- corresponding links in the copy.
+ -- Update the named association links for calls to mention the
+ -- copied actual parameters.
if Nkind_In (Old_Node, N_Entry_Call_Statement,
N_Function_Call,
and then Present (First_Named_Actual (Old_Node))
then
Adjust_Named_Associations (Old_Node, New_Node);
+
+ -- Update the Renamed_Object attribute of an object renaming
+ -- declaration to mention the replicated name.
+
+ elsif Nkind (Old_Node) = N_Object_Renaming_Declaration then
+ Set_Renamed_Object
+ (Defining_Entity (New_Node), Name (New_Node));
end if;
-- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
and then Present (First_Real_Statement (Old_Node))
then
declare
- Old_F : constant Node_Id := First_Real_Statement (Old_Node);
- N1, N2 : Node_Id;
+ Old_F : constant Node_Id := First_Real_Statement (Old_Node);
+ N1 : Node_Id;
+ N2 : Node_Id;
begin
N1 := First (Statements (Old_Node));
N_Case_Expression_Alternative =>
(1 => False, -- Actions (List1-Sem)
2 => False, -- unused
- 3 => True, -- Statements (List3)
- 4 => True, -- Expression (Node4)
+ 3 => True, -- Expression (Node3)
+ 4 => True, -- Discrete_Choices (List4)
5 => False), -- unused
N_Case_Statement =>
with System.OS_Lib; use System.OS_Lib;
-with Unchecked_Conversion;
-
package body Sinput.L is
Prep_Buffer : Text_Buffer_Ptr := null;
projects / gcc.git / commitdiff