+2013-10-14 Robert Dewar <dewar@adacore.com>
+
+ * freeze.adb (Freeze_Record): Don't give warning about packed
+ and foreign convention.
+
+2013-10-14 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aux.adb, sem_aux.ads (Package_Specification): New function, to
+ replace the less efficient idiom Specification.
+ (Unit_Declaration_Node (Pack_Id)), which handles library units and
+ child units.
+ * sem_ch3.adb, sem_ch10.adb, sem_prag.adb, sem_ch12.adb, sem_ch6.adb,
+ exp_disp.adb, sem_cat.adb, exp_dist.adb: Use Package_Specification.
+
+2013-10-14 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_attr.adb (Expand_Update_Attribute): Update the call to
+ Process_Range_Update.
+ (Process_Range_Update): Add new formal parameter Typ and associated
+ comment on usage. Add local constant Index_Typ. Add a type conversion
+ as part of the indexed component to ensure that the loop variable
+ corresponds to the index type.
+
2013-10-14 Tristan Gingold <gingold@adacore.com>
* a-exexpr-gcc.adb: Adjust comment.
procedure Process_Range_Update
(Temp : Entity_Id;
Comp : Node_Id;
- Expr : Node_Id);
+ Expr : Node_Id;
+ Typ : Entity_Id);
-- Generate the statements necessary to update a slice of the prefix.
-- The code is inserted before the attribute N. Temp denotes the entity
-- of the anonymous object created to reflect the changes in values.
-- Comp is range of the slice to be updated. Expr is an expression
- -- yielding the new value of Comp.
+ -- yielding the new value of Comp. Typ is the type of the prefix of
+ -- attribute Update.
-----------------------------------------
-- Process_Component_Or_Element_Update --
procedure Process_Range_Update
(Temp : Entity_Id;
Comp : Node_Id;
- Expr : Node_Id)
+ Expr : Node_Id;
+ Typ : Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (Comp);
- Index : Entity_Id;
+ Index_Typ : constant Entity_Id := Etype (First_Index (Typ));
+ Loc : constant Source_Ptr := Sloc (Comp);
+ Index : Entity_Id;
begin
-- A range update appears as
-- value of Expr:
-- for Index in Low .. High loop
- -- Temp (Index) := Expr;
+ -- Temp (<Index_Typ> (Index)) := Expr;
-- end loop;
Index := Make_Temporary (Loc, 'I');
Name =>
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (Temp, Loc),
- Expressions => New_List (New_Reference_To (Index, Loc))),
+ Expressions => New_List (
+ Convert_To (Index_Typ, New_Reference_To (Index, Loc)))),
Expression => Relocate_Node (Expr))),
End_Label => Empty));
-- Local variables
- Aggr : constant Node_Id := First (Expressions (N));
+ Aggr : constant Node_Id := First (Expressions (N));
Loc : constant Source_Ptr := Sloc (N);
- Pref : constant Node_Id := Prefix (N);
- Typ : constant Entity_Id := Etype (Pref);
+ Pref : constant Node_Id := Prefix (N);
+ Typ : constant Entity_Id := Etype (Pref);
Assoc : Node_Id;
Comp : Node_Id;
Expr : Node_Id;
Expr := Expression (Assoc);
while Present (Comp) loop
if Nkind (Comp) = N_Range then
- Process_Range_Update (Temp, Comp, Expr);
+ Process_Range_Update (Temp, Comp, Expr, Typ);
else
Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
end if;
end if;
return List_Containing (Parent (Typ)) =
- Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
+ Visible_Declarations (Package_Specification (Scop));
end Original_View_In_Visible_Part;
------------------
and then In_Private_Part (Current_Scope)
and then
List_Containing (Parent (Prim)) =
- Private_Declarations
- (Specification (Unit_Declaration_Node (Current_Scope)))
+ Private_Declarations (Package_Specification (Current_Scope))
and then Original_View_In_Visible_Part (Typ)
then
-- We exclude Input and Output stream operations because
if RCI_Locator = Empty then
RCI_Locator_Decl :=
- RCI_Package_Locator
- (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
+ RCI_Package_Locator (Loc, Package_Specification (RCI_Package));
Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
Analyze (RCI_Locator_Decl);
RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
if Has_Foreign_Convention (Etype (Comp))
and then Has_Pragma_Pack (Rec)
+
+ -- Don't warn for aliased components, since override
+ -- cannot happen in that case.
+
+ and then not Is_Aliased (Comp)
then
declare
CN : constant Name_Id :=
and then Has_Discriminants (Typ));
end Object_Type_Has_Constrained_Partial_View;
+ ---------------------------
+ -- Package_Specification --
+ ---------------------------
+
+ function Package_Specification (Pack_Id : Entity_Id) return Node_Id is
+ N : Node_Id;
+
+ begin
+ N := Parent (Pack_Id);
+
+ while Nkind (N) /= N_Package_Specification loop
+ N := Parent (N);
+
+ if No (N) then
+ raise Program_Error;
+ end if;
+ end loop;
+
+ return N;
+ end Package_Specification;
+
---------------
-- Tree_Read --
---------------
-- it returns the subprogram, task or protected body node for it. The unit
-- may be a child unit with any number of ancestors.
+ function Package_Specification (Pack_Id : Entity_Id) return Node_Id;
+ -- Given an entity for a package or generic package, return corresponding
+ -- package specification. Simplifies handling of child units, and better
+ -- than the old idiom: Specification (Unit_Declaration_Node (Pack_Id).
end Sem_Aux;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT 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- --
and then Is_Package_Or_Generic_Package (Unit_Entity)
and then Unit_Kind /= N_Package_Body
and then List_Containing (N) =
- Visible_Declarations
- (Specification (Unit_Declaration_Node (Unit_Entity)))
+ Visible_Declarations (Package_Specification (Unit_Entity))
and then not In_Package_Body (Unit_Entity)
and then not In_Instance;
Is_Private_Descendant (P_Name)
or else Private_Present (Parent (Lib_Unit)));
- P_Spec := Specification (Unit_Declaration_Node (P_Name));
+ P_Spec := Package_Specification (P_Name);
Push_Scope (P_Name);
-- Save current visibility of unit
(Related_Instance (Instance))));
else
Gen_Id :=
- Generic_Parent
- (Specification (Unit_Declaration_Node (Instance)));
+ Generic_Parent (Package_Specification (Instance));
end if;
Parent_Scope := Scope (Gen_Id);
-- of its generic parent.
if Is_Generic_Instance (Par) then
- Gen := Generic_Parent (Specification (Unit_Declaration_Node (Par)));
+ Gen := Generic_Parent (Package_Specification (Par));
Gen_E := First_Entity (Gen);
end if;
------------------
procedure Install_Spec (Par : Entity_Id) is
- Spec : constant Node_Id :=
- Specification (Unit_Declaration_Node (Par));
+ Spec : constant Node_Id := Package_Specification (Par);
begin
-- If this parent of the child instance is a top-level unit,
First_Par := Inst_Par;
- Gen_Par :=
- Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
+ Gen_Par := Generic_Parent (Package_Specification (Inst_Par));
First_Gen := Gen_Par;
Inst_Par := Renamed_Entity (Inst_Par);
end if;
- Gen_Par :=
- Generic_Parent
- (Specification (Unit_Declaration_Node (Inst_Par)));
+ Gen_Par := Generic_Parent (Package_Specification (Inst_Par));
if Present (Gen_Par) then
Prepend_Elmt (Inst_Par, Ancestors);
end if;
if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then
- Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack));
+ Parent_Spec := Package_Specification (Actual_Pack);
else
Parent_Spec := Parent (Actual_Pack);
end if;
elsif S = Current_Scope and then Is_Generic_Instance (S) then
declare
Par : constant Entity_Id :=
- Generic_Parent
- (Specification (Unit_Declaration_Node (S)));
+ Generic_Parent (Package_Specification (S));
begin
if Present (Par)
and then P = Scope (Par)
elsif Ekind (Current_Scope) = E_Package
and then
List_Containing (Parent (Prev)) /=
- Visible_Declarations
- (Specification (Unit_Declaration_Node (Current_Scope)))
+ Visible_Declarations (Package_Specification (Current_Scope))
then
Error_Msg_N
("deferred constant must be declared in visible part",
and then In_Private_Part (Current_Scope)
then
Priv_Decls :=
- Private_Declarations
- (Specification (Unit_Declaration_Node (Current_Scope)));
+ Private_Declarations (Package_Specification (Current_Scope));
return In_Package_Body (Current_Scope)
or else
-- Local variables
- Pack_Spec : constant Node_Id := Parent (Spec_Id);
+ Pack_Spec : constant Node_Id := Package_Specification (Spec_Id);
-- Start of processing for Collect_Hidden_States
projects / gcc.git / commitdiff