Commit 2791be24 by Arnaud Charlet

[multiple changes]

2012-10-01  Robert Dewar  <dewar@adacore.com>

	* sinfo.ads, exp_aggr.adb, sem_ch13.adb: Minor reformatting.

2012-10-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb (Resolve_Array_Aggregate): Handle properly
	component associations given by subtypes that have static
	predicates.  Improve error message for overlapping ranges in
	array aggregates.

2012-10-01  Pascal Obry  <obry@adacore.com>

	* snames.ads-tmpl (Name_Link_Lib_Subdir): New constant.

2012-10-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch9.adb (Analyze_Requeue): The target of a requeue
	statement on a protected entry must be a variable. This is part
	of AI05-0225.

From-SVN: r191889
parent f686b370
2012-10-01 Robert Dewar <dewar@adacore.com>
* sinfo.ads, exp_aggr.adb, sem_ch13.adb: Minor reformatting.
2012-10-01 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Resolve_Array_Aggregate): Handle properly
component associations given by subtypes that have static
predicates. Improve error message for overlapping ranges in
array aggregates.
2012-10-01 Pascal Obry <obry@adacore.com>
* snames.ads-tmpl (Name_Link_Lib_Subdir): New constant.
2012-10-01 Ed Schonberg <schonberg@adacore.com>
* sem_ch9.adb (Analyze_Requeue): The target of a requeue
statement on a protected entry must be a variable. This is part
of AI05-0225.
2012-09-26 Ian Lance Taylor <iant@google.com> 2012-09-26 Ian Lance Taylor <iant@google.com>
* gcc-interface/Makefile.in (LIBBACKTRACE): New variable. * gcc-interface/Makefile.in (LIBBACKTRACE): New variable.
......
...@@ -239,12 +239,13 @@ package body Exp_Aggr is ...@@ -239,12 +239,13 @@ package body Exp_Aggr is
-- N is the N_Aggregate node to be expanded. -- N is the N_Aggregate node to be expanded.
function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean; function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean;
-- For two-dimensional packed aggregates with constant bounds and constant -- For two-dimensional packed aggregates with constant bounds and constant
-- components, it is preferable to pack the inner aggregates because the -- components, it is preferable to pack the inner aggregates because the
-- whole matrix can then be presented to the back-end as a one-dimensional -- whole matrix can then be presented to the back-end as a one-dimensional
-- list of literals. This is much more efficient than expanding into single -- list of literals. This is much more efficient than expanding into single
-- component assignments. -- component assignments. This function determines if the type Typ is for
-- an array that is suitable for this optimization: it returns True if Typ
-- is a two dimensional bit packed array with component size 1, 2, or 4.
function Late_Expansion function Late_Expansion
(N : Node_Id; (N : Node_Id;
...@@ -5924,8 +5925,7 @@ package body Exp_Aggr is ...@@ -5924,8 +5925,7 @@ package body Exp_Aggr is
begin begin
return Number_Dimensions (Typ) = 2 return Number_Dimensions (Typ) = 2
and then Is_Bit_Packed_Array (Typ) and then Is_Bit_Packed_Array (Typ)
and then and then (C = 1 or else C = 2 or else C = 4);
(C = 1 or else C = 2 or else C = 4);
end Is_Two_Dim_Packed_Array; end Is_Two_Dim_Packed_Array;
-------------------- --------------------
......
...@@ -1726,6 +1726,9 @@ package body Sem_Aggr is ...@@ -1726,6 +1726,9 @@ package body Sem_Aggr is
Discard : Node_Id; Discard : Node_Id;
pragma Warnings (Off, Discard); pragma Warnings (Off, Discard);
Delete_Choice : Boolean;
-- Used when replacing a subtype choice with predicate by a list
Aggr_Low : Node_Id := Empty; Aggr_Low : Node_Id := Empty;
Aggr_High : Node_Id := Empty; Aggr_High : Node_Id := Empty;
-- The actual low and high bounds of this sub-aggregate -- The actual low and high bounds of this sub-aggregate
...@@ -1766,6 +1769,8 @@ package body Sem_Aggr is ...@@ -1766,6 +1769,8 @@ package body Sem_Aggr is
Assoc := First (Component_Associations (N)); Assoc := First (Component_Associations (N));
while Present (Assoc) loop while Present (Assoc) loop
Choice := First (Choices (Assoc)); Choice := First (Choices (Assoc));
Delete_Choice := False;
while Present (Choice) loop while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then if Nkind (Choice) = N_Others_Choice then
Others_Present := True; Others_Present := True;
...@@ -1792,10 +1797,56 @@ package body Sem_Aggr is ...@@ -1792,10 +1797,56 @@ package body Sem_Aggr is
Error_Msg_N Error_Msg_N
("(Ada 83) illegal context for OTHERS choice", N); ("(Ada 83) illegal context for OTHERS choice", N);
end if; end if;
elsif Is_Entity_Name (Choice) then
Analyze (Choice);
declare
E : constant Entity_Id := Entity (Choice);
New_Cs : List_Id;
P : Node_Id;
C : Node_Id;
begin
if Is_Type (E) and then Has_Predicates (E) then
Freeze_Before (N, E);
-- If the subtype has a static predicate, replace the
-- original choice with the list of individual values
-- covered by the predicate.
if Present (Static_Predicate (E)) then
Delete_Choice := True;
New_Cs := New_List;
P := First (Static_Predicate (E));
while Present (P) loop
C := New_Copy (P);
Set_Sloc (C, Sloc (Choice));
Append_To (New_Cs, C);
Next (P);
end loop;
Insert_List_After (Choice, New_Cs);
end if;
end if;
end;
end if; end if;
Nb_Choices := Nb_Choices + 1; Nb_Choices := Nb_Choices + 1;
Next (Choice);
declare
C : constant Node_Id := Choice;
begin
Next (Choice);
if Delete_Choice then
Remove (C);
Nb_Choices := Nb_Choices - 1;
Delete_Choice := False;
end if;
end;
end loop; end loop;
Next (Assoc); Next (Assoc);
...@@ -1998,6 +2049,7 @@ package body Sem_Aggr is ...@@ -1998,6 +2049,7 @@ package body Sem_Aggr is
Nb_Discrete_Choices := Nb_Discrete_Choices + 1; Nb_Discrete_Choices := Nb_Discrete_Choices + 1;
Table (Nb_Discrete_Choices).Choice_Lo := Low; Table (Nb_Discrete_Choices).Choice_Lo := Low;
Table (Nb_Discrete_Choices).Choice_Hi := High; Table (Nb_Discrete_Choices).Choice_Hi := High;
Table (Nb_Discrete_Choices).Choice_Node := Choice;
Next (Choice); Next (Choice);
...@@ -2115,7 +2167,7 @@ package body Sem_Aggr is ...@@ -2115,7 +2167,7 @@ package body Sem_Aggr is
then then
Error_Msg_N Error_Msg_N
("duplicate choice values in array aggregate", ("duplicate choice values in array aggregate",
Table (J).Choice_Hi); Table (J).Choice_Node);
return Failure; return Failure;
elsif not Others_Present then elsif not Others_Present then
......
...@@ -856,7 +856,7 @@ package body Sem_Ch13 is ...@@ -856,7 +856,7 @@ package body Sem_Ch13 is
-- Start of processing for Analyze_Aspects_At_Freeze_Point -- Start of processing for Analyze_Aspects_At_Freeze_Point
begin begin
-- Must be visible in current scope. -- Must be visible in current scope
if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then
return; return;
...@@ -7966,18 +7966,20 @@ package body Sem_Ch13 is ...@@ -7966,18 +7966,20 @@ package body Sem_Ch13 is
(Entity (Rep_Item), Aspect_Rep_Item (Rep_Item)); (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item; end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item;
-- Start of processing for Inherit_Aspects_At_Freeze_Point
begin begin
-- A representation item is either subtype-specific (Size and Alignment -- A representation item is either subtype-specific (Size and Alignment
-- clauses) or type-related (all others). Subtype-specific aspects may -- clauses) or type-related (all others). Subtype-specific aspects may
-- differ for different subtypes of the same type.(RM 13.1.8) -- differ for different subtypes of the same type (RM 13.1.8).
-- A derived type inherits each type-related representation aspect of -- A derived type inherits each type-related representation aspect of
-- its parent type that was directly specified before the declaration of -- its parent type that was directly specified before the declaration of
-- the derived type. (RM 13.1.15) -- the derived type (RM 13.1.15).
-- A derived subtype inherits each subtype-specific representation -- A derived subtype inherits each subtype-specific representation
-- aspect of its parent subtype that was directly specified before the -- aspect of its parent subtype that was directly specified before the
-- declaration of the derived type .(RM 13.1.15) -- declaration of the derived type (RM 13.1.15).
-- The general processing involves inheriting a representation aspect -- The general processing involves inheriting a representation aspect
-- from a parent type whenever the first rep item (aspect specification, -- from a parent type whenever the first rep item (aspect specification,
...@@ -7986,11 +7988,11 @@ package body Sem_Ch13 is ...@@ -7986,11 +7988,11 @@ package body Sem_Ch13 is
-- directly specified to Typ but to one of its parents. -- directly specified to Typ but to one of its parents.
-- ??? Note that, for now, just a limited number of representation -- ??? Note that, for now, just a limited number of representation
-- aspects have been inherited here so far. Many of them are still -- aspects have been inherited here so far. Many of them are
-- inherited in Sem_Ch3. This will be fixed soon. Here is a -- still inherited in Sem_Ch3. This will be fixed soon. Here is
-- non-exhaustive list of aspects that likely also need to be moved to -- a non- exhaustive list of aspects that likely also need to
-- this routine: Alignment, Component_Alignment, Component_Size, -- be moved to this routine: Alignment, Component_Alignment,
-- Machine_Radix, Object_Size, Pack, Predicates, -- Component_Size, Machine_Radix, Object_Size, Pack, Predicates,
-- Preelaborable_Initialization, RM_Size and Small. -- Preelaborable_Initialization, RM_Size and Small.
if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then
...@@ -8029,7 +8031,7 @@ package body Sem_Ch13 is ...@@ -8029,7 +8031,7 @@ package body Sem_Ch13 is
Set_Is_Volatile (Typ); Set_Is_Volatile (Typ);
end if; end if;
-- Default_Component_Value. -- Default_Component_Value
if Is_Array_Type (Typ) if Is_Array_Type (Typ)
and then Has_Rep_Item (Typ, Name_Default_Component_Value, False) and then Has_Rep_Item (Typ, Name_Default_Component_Value, False)
...@@ -8040,7 +8042,7 @@ package body Sem_Ch13 is ...@@ -8040,7 +8042,7 @@ package body Sem_Ch13 is
(Entity (Get_Rep_Item (Typ, Name_Default_Component_Value)))); (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value))));
end if; end if;
-- Default_Value. -- Default_Value
if Is_Scalar_Type (Typ) if Is_Scalar_Type (Typ)
and then Has_Rep_Item (Typ, Name_Default_Value, False) and then Has_Rep_Item (Typ, Name_Default_Value, False)
...@@ -8135,6 +8137,7 @@ package body Sem_Ch13 is ...@@ -8135,6 +8137,7 @@ package body Sem_Ch13 is
-- Record type specific aspects -- Record type specific aspects
if Is_Record_Type (Typ) then if Is_Record_Type (Typ) then
-- Bit_Order -- Bit_Order
if not Has_Rep_Item (Typ, Name_Bit_Order, False) if not Has_Rep_Item (Typ, Name_Bit_Order, False)
......
...@@ -2379,6 +2379,18 @@ package body Sem_Ch9 is ...@@ -2379,6 +2379,18 @@ package body Sem_Ch9 is
end; end;
end if; end if;
end if; end if;
-- AI05-0225: the target protected object of a requeue must be a
-- variable. This is a binding interpretation that applies to all
-- versions of the language.
if Present (Target_Obj)
and then Ekind (Scope (Entry_Id)) in Protected_Kind
and then not Is_Variable (Target_Obj)
then
Error_Msg_N
("target protected object of requeue must be a variable", N);
end if;
end Analyze_Requeue; end Analyze_Requeue;
------------------------------ ------------------------------
......
...@@ -668,9 +668,8 @@ package Sinfo is ...@@ -668,9 +668,8 @@ package Sinfo is
-- Compile_Time_Known_Aggregate (Flag18-Sem) -- Compile_Time_Known_Aggregate (Flag18-Sem)
-- Present in N_Aggregate nodes. Set for aggregates which can be fully -- Present in N_Aggregate nodes. Set for aggregates which can be fully
-- evaluated at compile time without raising constraint error. Such -- evaluated at compile time without raising constraint error. Such
-- aggregates can be passed as is to Gigi without any expansion. See -- aggregates can be passed as is the back end without any expansion.
-- Exp_Aggr for the specific conditions under which an aggregate has this -- See Exp_Aggr for specific conditions under which this flag gets set.
-- flag set.
-- Componentwise_Assignment (Flag14-Sem) -- Componentwise_Assignment (Flag14-Sem)
-- Present in N_Assignment_Statement nodes. Set for a record assignment -- Present in N_Assignment_Statement nodes. Set for a record assignment
......
...@@ -1208,6 +1208,7 @@ package Snames is ...@@ -1208,6 +1208,7 @@ package Snames is
Name_Leading_Required_Switches : constant Name_Id := N + $; Name_Leading_Required_Switches : constant Name_Id := N + $;
Name_Leading_Switches : constant Name_Id := N + $; Name_Leading_Switches : constant Name_Id := N + $;
Name_Lib_Subdir : constant Name_Id := N + $; Name_Lib_Subdir : constant Name_Id := N + $;
Name_Link_Lib_Subdir : constant Name_Id := N + $;
Name_Library : constant Name_Id := N + $; Name_Library : constant Name_Id := N + $;
Name_Library_Ali_Dir : constant Name_Id := N + $; Name_Library_Ali_Dir : constant Name_Id := N + $;
Name_Library_Auto_Init : constant Name_Id := N + $; Name_Library_Auto_Init : constant Name_Id := N + $;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment