diff options
| author | Robert Dewar <dewar@adacore.com> | 2010-06-17 09:57:32 +0000 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2010-06-17 11:57:32 +0200 |
| commit | 8a95f4e86791d06494bd5fc8b0da29b9651530fb (patch) | |
| tree | ffaf92cdf6f090cddfad2f2f57c2f05d9ad2a9c8 /gcc/ada | |
| parent | e1b871e93c547d7fe50bc5c30fb18c1bd3ba16da (diff) | |
| download | gcc-8a95f4e86791d06494bd5fc8b0da29b9651530fb.zip gcc-8a95f4e86791d06494bd5fc8b0da29b9651530fb.tar.gz gcc-8a95f4e86791d06494bd5fc8b0da29b9651530fb.tar.bz2 | |
sem_intr.adb, [...]: Minor reformatting.
2010-06-17 Robert Dewar <dewar@adacore.com>
* sem_intr.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb,
sem_warn.adb, sem_eval.adb: Minor reformatting. Use Ekind_In.
(Set_Slice_Subtype): Explicitly freeze the slice's itype at the point
where the slice's actions are inserted.
(Decompose_Expr): Account for possible rewriting of slice bounds
resulting from side effects suppression caused by the above freezing,
so that folding of bounds is preserved by such rewriting.
2010-06-17 Robert Dewar <dewar@adacore.com>
* einfo.ads, einfo.adb (Get_Record_Representation_Clause): New function.
* freeze.adb (Freeze_Record_Type): Add call to
Check_Record_Representation_Clause.
* sem_ch13.adb (Check_Record_Representation_Clause): New function
(Analyze_Record_Representation_Clause): Split out overlap code into this
new function.
(Check_Component_Overlap): Moved inside
Check_Record_Representation_Clause.
* sem_ch13.ads (Check_Record_Representation_Clause): New function.
From-SVN: r160892
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 22 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 144 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 1574 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 34 | ||||
| -rw-r--r-- | gcc/ada/sem_intr.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 55 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/sem_warn.adb | 11 |
13 files changed, 1102 insertions, 873 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1392d19..33e1f43 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,27 @@ 2010-06-17 Robert Dewar <dewar@adacore.com> + * sem_intr.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb, + sem_warn.adb, sem_eval.adb: Minor reformatting. Use Ekind_In. + (Set_Slice_Subtype): Explicitly freeze the slice's itype at the point + where the slice's actions are inserted. + (Decompose_Expr): Account for possible rewriting of slice bounds + resulting from side effects suppression caused by the above freezing, + so that folding of bounds is preserved by such rewriting. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * einfo.ads, einfo.adb (Get_Record_Representation_Clause): New function. + * freeze.adb (Freeze_Record_Type): Add call to + Check_Record_Representation_Clause. + * sem_ch13.adb (Check_Record_Representation_Clause): New function + (Analyze_Record_Representation_Clause): Split out overlap code into this + new function. + (Check_Component_Overlap): Moved inside + Check_Record_Representation_Clause. + * sem_ch13.ads (Check_Record_Representation_Clause): New function. + +2010-06-17 Robert Dewar <dewar@adacore.com> + * back_end.adb, sem_res.adb, switch-c.adb, sem_scil.adb: Minor reformatting. * sem_attr.adb, sem_cat.adb, sem_disp.adb, sem_elab.adb, sem_elim.adb, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 7b20078..da4ed38 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -5760,6 +5760,26 @@ package body Einfo is end if; end Get_Full_View; + -------------------------------------- + -- Get_Record_Representation_Clause -- + -------------------------------------- + + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is + N : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Record_Representation_Clause then + return N; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Record_Representation_Clause; + -------------------- -- Get_Rep_Pragma -- -------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d9ff8c0..99c7141 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -6767,6 +6767,11 @@ package Einfo is -- value returned is the N_Attribute_Definition_Clause node, otherwise -- Empty is returned. + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; + -- Searches the Rep_Item chain for a given entyt E, for a record + -- representation clause, and if found, returns it. Returns Empty + -- if no such clause is found. + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id; -- Searches the Rep_Item chain for the given entity E, for an instance -- a representation pragma with the given name Nam. If found then the diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 47befcd..0f126cf 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1776,7 +1776,7 @@ package body Freeze is Prev := Empty; while Present (Comp) loop - -- First handle the (real) component case + -- First handle the component case if Ekind (Comp) = E_Component or else Ekind (Comp) = E_Discriminant @@ -1847,129 +1847,12 @@ package body Freeze is Component_Name (Component_Clause (Comp))); end if; end if; - - -- If component clause is present, then deal with the non- - -- default bit order case for Ada 95 mode. The required - -- processing for Ada 2005 mode is handled separately after - -- processing all components. - - -- We only do this processing for the base type, and in - -- fact that's important, since otherwise if there are - -- record subtypes, we could reverse the bits once for - -- each subtype, which would be incorrect. - - if Present (CC) - and then Reverse_Bit_Order (Rec) - and then Ekind (E) = E_Record_Type - and then Ada_Version <= Ada_95 - then - declare - CFB : constant Uint := Component_Bit_Offset (Comp); - CSZ : constant Uint := Esize (Comp); - CLC : constant Node_Id := Component_Clause (Comp); - Pos : constant Node_Id := Position (CLC); - FB : constant Node_Id := First_Bit (CLC); - - Storage_Unit_Offset : constant Uint := - CFB / System_Storage_Unit; - - Start_Bit : constant Uint := - CFB mod System_Storage_Unit; - - begin - -- Cases where field goes over storage unit boundary - - if Start_Bit + CSZ > System_Storage_Unit then - - -- Allow multi-byte field but generate warning - - if Start_Bit mod System_Storage_Unit = 0 - and then CSZ mod System_Storage_Unit = 0 - then - Error_Msg_N - ("multi-byte field specified with non-standard" - & " Bit_Order?", CLC); - - if Bytes_Big_Endian then - Error_Msg_N - ("bytes are not reversed " - & "(component is big-endian)?", CLC); - else - Error_Msg_N - ("bytes are not reversed " - & "(component is little-endian)?", CLC); - end if; - - -- Do not allow non-contiguous field - - else - Error_Msg_N - ("attempt to specify non-contiguous field " - & "not permitted", CLC); - Error_Msg_N - ("\caused by non-standard Bit_Order " - & "specified", CLC); - Error_Msg_N - ("\consider possibility of using " - & "Ada 2005 mode here", CLC); - end if; - - -- Case where field fits in one storage unit - - else - -- Give warning if suspicious component clause - - if Intval (FB) >= System_Storage_Unit - and then Warn_On_Reverse_Bit_Order - then - Error_Msg_N - ("?Bit_Order clause does not affect " & - "byte ordering", Pos); - Error_Msg_Uint_1 := - Intval (Pos) + Intval (FB) / - System_Storage_Unit; - Error_Msg_N - ("?position normalized to ^ before bit " & - "order interpreted", Pos); - end if; - - -- Here is where we fix up the Component_Bit_Offset - -- value to account for the reverse bit order. - -- Some examples of what needs to be done are: - - -- First_Bit .. Last_Bit Component_Bit_Offset - -- old new old new - - -- 0 .. 0 7 .. 7 0 7 - -- 0 .. 1 6 .. 7 0 6 - -- 0 .. 2 5 .. 7 0 5 - -- 0 .. 7 0 .. 7 0 4 - - -- 1 .. 1 6 .. 6 1 6 - -- 1 .. 4 3 .. 6 1 3 - -- 4 .. 7 0 .. 3 4 0 - - -- The general rule is that the first bit is - -- is obtained by subtracting the old ending bit - -- from storage_unit - 1. - - Set_Component_Bit_Offset - (Comp, - (Storage_Unit_Offset * System_Storage_Unit) + - (System_Storage_Unit - 1) - - (Start_Bit + CSZ - 1)); - - Set_Normalized_First_Bit - (Comp, - Component_Bit_Offset (Comp) mod - System_Storage_Unit); - end if; - end; - end if; end; end if; - -- Gather data for possible Implicit_Packing later + -- Gather data for possible Implicit_Packing later. Note that at + -- this stage we might be dealing with a real component, or with + -- an implicit subtype declaration. if not Is_Scalar_Type (Etype (Comp)) then All_Scalar_Components := False; @@ -2118,7 +2001,7 @@ package body Freeze is Next_Entity (Comp); end loop; - -- Deal with pragma Bit_Order + -- Deal with pragma Bit_Order setting non-standard bit order if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then if not Placed_Component then @@ -2129,14 +2012,25 @@ package body Freeze is Error_Msg_N ("\?since no component clauses were specified", ADC); - -- Here is where we do Ada 2005 processing for bit order (the Ada - -- 95 case was already taken care of above). + -- Here is where we do the processing for reversed bit order - elsif Ada_Version >= Ada_05 then + else Adjust_Record_For_Reverse_Bit_Order (Rec); end if; end if; + -- Complete error checking on record representation clause (e.g. + -- overlap of components). This is called after adjusting the + -- record for reverse bit order. + + declare + RRC : constant Node_Id := Get_Record_Representation_Clause (Rec); + begin + if Present (RRC) then + Check_Record_Representation_Clause (RRC); + end if; + end; + -- Set OK_To_Reorder_Components depending on debug flags if Rec = Base_Type (Rec) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8d5cb08..7e2fe5f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -73,10 +73,6 @@ package body Sem_Ch13 is -- inherited from a derived type that is no longer appropriate for the -- new Esize value. In this case, we reset the Alignment to unknown. - procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); - -- Given two entities for record components or discriminants, checks - -- if they have overlapping component clauses and issues errors if so. - function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding -- Uint value. If the value is inappropriate, then error messages are @@ -180,265 +176,421 @@ package body Sem_Ch13 is ----------------------------------------- procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is - Max_Machine_Scalar_Size : constant Uint := - UI_From_Int - (Standard_Long_Long_Integer_Size); - -- We use this as the maximum machine scalar size in the sense of AI-133 - - Num_CC : Natural; - Comp : Entity_Id; - SSU : constant Uint := UI_From_Int (System_Storage_Unit); + Comp : Node_Id; + CC : Node_Id; begin - -- This first loop through components does two things. First it deals - -- with the case of components with component clauses whose length is - -- greater than the maximum machine scalar size (either accepting them - -- or rejecting as needed). Second, it counts the number of components - -- with component clauses whose length does not exceed this maximum for - -- later processing. - - Num_CC := 0; - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop - declare - CC : constant Node_Id := Component_Clause (Comp); + -- Processing depends on version of Ada - begin - if Present (CC) then - declare - Fbit : constant Uint := Static_Integer (First_Bit (CC)); + case Ada_Version is - begin - -- Case of component with size > max machine scalar + -- For Ada 95, we just renumber bits within a storage unit. We do + -- the same for Ada 83 mode, since we recognize pragma Bit_Order + -- in Ada 83, and are free to add this extension. - if Esize (Comp) > Max_Machine_Scalar_Size then + when Ada_83 | Ada_95 => + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); - -- Must begin on byte boundary + -- If component clause is present, then deal with the non- + -- default bit order case for Ada 95 mode. - if Fbit mod SSU /= 0 then - Error_Msg_N - ("illegal first bit value for reverse bit order", - First_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + -- We only do this processing for the base type, and in + -- fact that's important, since otherwise if there are + -- record subtypes, we could reverse the bits once for + -- each subtype, which would be incorrect. - Error_Msg_N - ("\must be a multiple of ^ if size greater than ^", - First_Bit (CC)); + if Present (CC) + and then Ekind (R) = E_Record_Type + then + declare + CFB : constant Uint := Component_Bit_Offset (Comp); + CSZ : constant Uint := Esize (Comp); + CLC : constant Node_Id := Component_Clause (Comp); + Pos : constant Node_Id := Position (CLC); + FB : constant Node_Id := First_Bit (CLC); - -- Must end on byte boundary + Storage_Unit_Offset : constant Uint := + CFB / System_Storage_Unit; - elsif Esize (Comp) mod SSU /= 0 then - Error_Msg_N - ("illegal last bit value for reverse bit order", - Last_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + Start_Bit : constant Uint := + CFB mod System_Storage_Unit; - Error_Msg_N - ("\must be a multiple of ^ if size greater than ^", - Last_Bit (CC)); + begin + -- Cases where field goes over storage unit boundary - -- OK, give warning if enabled + if Start_Bit + CSZ > System_Storage_Unit then - elsif Warn_On_Reverse_Bit_Order then - Error_Msg_N - ("multi-byte field specified with non-standard" - & " Bit_Order?", CC); + -- Allow multi-byte field but generate warning - if Bytes_Big_Endian then + if Start_Bit mod System_Storage_Unit = 0 + and then CSZ mod System_Storage_Unit = 0 + then Error_Msg_N - ("\bytes are not reversed " - & "(component is big-endian)?", CC); + ("multi-byte field specified with non-standard" + & " Bit_Order?", CLC); + + if Bytes_Big_Endian then + Error_Msg_N + ("bytes are not reversed " + & "(component is big-endian)?", CLC); + else + Error_Msg_N + ("bytes are not reversed " + & "(component is little-endian)?", CLC); + end if; + + -- Do not allow non-contiguous field + else Error_Msg_N - ("\bytes are not reversed " - & "(component is little-endian)?", CC); + ("attempt to specify non-contiguous field " + & "not permitted", CLC); + Error_Msg_N + ("\caused by non-standard Bit_Order " + & "specified", CLC); + Error_Msg_N + ("\consider possibility of using " + & "Ada 2005 mode here", CLC); end if; - end if; - -- Case where size is not greater than max machine - -- scalar. For now, we just count these. + -- Case where field fits in one storage unit - else - Num_CC := Num_CC + 1; - end if; - end; - end if; - end; + else + -- Give warning if suspicious component clause - Next_Component_Or_Discriminant (Comp); - end loop; + if Intval (FB) >= System_Storage_Unit + and then Warn_On_Reverse_Bit_Order + then + Error_Msg_N + ("?Bit_Order clause does not affect " & + "byte ordering", Pos); + Error_Msg_Uint_1 := + Intval (Pos) + Intval (FB) / + System_Storage_Unit; + Error_Msg_N + ("?position normalized to ^ before bit " & + "order interpreted", Pos); + end if; - -- We need to sort the component clauses on the basis of the Position - -- values in the clause, so we can group clauses with the same Position. - -- together to determine the relevant machine scalar size. + -- Here is where we fix up the Component_Bit_Offset + -- value to account for the reverse bit order. + -- Some examples of what needs to be done are: - declare - Comps : array (0 .. Num_CC) of Entity_Id; - -- Array to collect component and discriminant entities. The data - -- starts at index 1, the 0'th entry is for the sort routine. + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new - function CP_Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 - procedure CP_Move (From : Natural; To : Natural); - -- Move routine for Sort + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 - package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); + -- The general rule is that the first bit is + -- is obtained by subtracting the old ending bit + -- from storage_unit - 1. - Start : Natural; - Stop : Natural; - -- Start and stop positions in component list of set of components - -- with the same starting position (that constitute components in - -- a single machine scalar). + Set_Component_Bit_Offset + (Comp, + (Storage_Unit_Offset * System_Storage_Unit) + + (System_Storage_Unit - 1) - + (Start_Bit + CSZ - 1)); - MaxL : Uint; - -- Maximum last bit value of any component in this set + Set_Normalized_First_Bit + (Comp, + Component_Bit_Offset (Comp) mod + System_Storage_Unit); + end if; + end; + end if; - MSS : Uint; - -- Corresponding machine scalar size + Next_Component_Or_Discriminant (Comp); + end loop; - ----------- - -- CP_Lt -- - ----------- + -- For Ada 2005, we do machine scalar processing, as fully described + -- In AI-133. This involves gathering all components which start at + -- the same byte offset and processing them together - function CP_Lt (Op1, Op2 : Natural) return Boolean is - begin - return Position (Component_Clause (Comps (Op1))) < - Position (Component_Clause (Comps (Op2))); - end CP_Lt; + when Ada_05 => + declare + Max_Machine_Scalar_Size : constant Uint := + UI_From_Int + (Standard_Long_Long_Integer_Size); + -- We use this as the maximum machine scalar size - ------------- - -- CP_Move -- - ------------- + Num_CC : Natural; + SSU : constant Uint := UI_From_Int (System_Storage_Unit); - procedure CP_Move (From : Natural; To : Natural) is - begin - Comps (To) := Comps (From); - end CP_Move; + begin + -- This first loop through components does two things. First it + -- deals with the case of components with component clauses + -- whose length is greater than the maximum machine scalar size + -- (either accepting them or rejecting as needed). Second, it + -- counts the number of components with component clauses whose + -- length does not exceed this maximum for later processing. + + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); - begin - -- Collect the component clauses + if Present (CC) then + declare + Fbit : constant Uint := + Static_Integer (First_Bit (CC)); - Num_CC := 0; - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop - if Present (Component_Clause (Comp)) - and then Esize (Comp) <= Max_Machine_Scalar_Size - then - Num_CC := Num_CC + 1; - Comps (Num_CC) := Comp; - end if; + begin + -- Case of component with size > max machine scalar + + if Esize (Comp) > Max_Machine_Scalar_Size then + + -- Must begin on byte boundary + + if Fbit mod SSU /= 0 then + Error_Msg_N + ("illegal first bit value for " + & "reverse bit order", + First_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + + Error_Msg_N + ("\must be a multiple of ^ " + & "if size greater than ^", + First_Bit (CC)); + + -- Must end on byte boundary + + elsif Esize (Comp) mod SSU /= 0 then + Error_Msg_N + ("illegal last bit value for " + & "reverse bit order", + Last_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + + Error_Msg_N + ("\must be a multiple of ^ if size " + & "greater than ^", + Last_Bit (CC)); + + -- OK, give warning if enabled + + elsif Warn_On_Reverse_Bit_Order then + Error_Msg_N + ("multi-byte field specified with " + & " non-standard Bit_Order?", CC); + + if Bytes_Big_Endian then + Error_Msg_N + ("\bytes are not reversed " + & "(component is big-endian)?", CC); + else + Error_Msg_N + ("\bytes are not reversed " + & "(component is little-endian)?", CC); + end if; + end if; - Next_Component_Or_Discriminant (Comp); - end loop; + -- Case where size is not greater than max machine + -- scalar. For now, we just count these. - -- Sort by ascending position number - - Sorting.Sort (Num_CC); - - -- We now have all the components whose size does not exceed the max - -- machine scalar value, sorted by starting position. In this loop - -- we gather groups of clauses starting at the same position, to - -- process them in accordance with Ada 2005 AI-133. - - Stop := 0; - while Stop < Num_CC loop - Start := Stop + 1; - Stop := Start; - MaxL := - Static_Integer (Last_Bit (Component_Clause (Comps (Start)))); - while Stop < Num_CC loop - if Static_Integer - (Position (Component_Clause (Comps (Stop + 1)))) = - Static_Integer - (Position (Component_Clause (Comps (Stop)))) - then - Stop := Stop + 1; - MaxL := - UI_Max - (MaxL, - Static_Integer - (Last_Bit (Component_Clause (Comps (Stop))))); - else - exit; - end if; - end loop; + else + Num_CC := Num_CC + 1; + end if; + end; + end if; - -- Now we have a group of component clauses from Start to Stop - -- whose positions are identical, and MaxL is the maximum last bit - -- value of any of these components. + Next_Component_Or_Discriminant (Comp); + end loop; - -- We need to determine the corresponding machine scalar size. - -- This loop assumes that machine scalar sizes are even, and that - -- each possible machine scalar has twice as many bits as the - -- next smaller one. + -- We need to sort the component clauses on the basis of the + -- Position values in the clause, so we can group clauses with + -- the same Position. together to determine the relevant + -- machine scalar size. - MSS := Max_Machine_Scalar_Size; - while MSS mod 2 = 0 - and then (MSS / 2) >= SSU - and then (MSS / 2) > MaxL - loop - MSS := MSS / 2; - end loop; + Sort_CC : declare + Comps : array (0 .. Num_CC) of Entity_Id; + -- Array to collect component and discriminant entities. The + -- data starts at index 1, the 0'th entry is for the sort + -- routine. - -- Here is where we fix up the Component_Bit_Offset value to - -- account for the reverse bit order. Some examples of what needs - -- to be done for the case of a machine scalar size of 8 are: + function CP_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort - -- First_Bit .. Last_Bit Component_Bit_Offset - -- old new old new + procedure CP_Move (From : Natural; To : Natural); + -- Move routine for Sort - -- 0 .. 0 7 .. 7 0 7 - -- 0 .. 1 6 .. 7 0 6 - -- 0 .. 2 5 .. 7 0 5 - -- 0 .. 7 0 .. 7 0 4 + package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); - -- 1 .. 1 6 .. 6 1 6 - -- 1 .. 4 3 .. 6 1 3 - -- 4 .. 7 0 .. 3 4 0 + Start : Natural; + Stop : Natural; + -- Start and stop positions in component list of set of + -- components with the same starting position (that + -- constitute components in a single machine scalar). - -- The general rule is that the first bit is obtained by - -- subtracting the old ending bit from machine scalar size - 1. + MaxL : Uint; + -- Maximum last bit value of any component in this set - for C in Start .. Stop loop - declare - Comp : constant Entity_Id := Comps (C); - CC : constant Node_Id := Component_Clause (Comp); - LB : constant Uint := Static_Integer (Last_Bit (CC)); - NFB : constant Uint := MSS - Uint_1 - LB; - NLB : constant Uint := NFB + Esize (Comp) - 1; - Pos : constant Uint := Static_Integer (Position (CC)); + MSS : Uint; + -- Corresponding machine scalar size + + ----------- + -- CP_Lt -- + ----------- + + function CP_Lt (Op1, Op2 : Natural) return Boolean is + begin + return Position (Component_Clause (Comps (Op1))) < + Position (Component_Clause (Comps (Op2))); + end CP_Lt; + + ------------- + -- CP_Move -- + ------------- + + procedure CP_Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end CP_Move; + + -- Start of processing for Sort_CC begin - if Warn_On_Reverse_Bit_Order then - Error_Msg_Uint_1 := MSS; - Error_Msg_N - ("info: reverse bit order in machine " & - "scalar of length^?", First_Bit (CC)); - Error_Msg_Uint_1 := NFB; - Error_Msg_Uint_2 := NLB; + -- Collect the component clauses - if Bytes_Big_Endian then - Error_Msg_NE - ("?\info: big-endian range for " - & "component & is ^ .. ^", - First_Bit (CC), Comp); - else - Error_Msg_NE - ("?\info: little-endian range " - & "for component & is ^ .. ^", - First_Bit (CC), Comp); + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + if Present (Component_Clause (Comp)) + and then Esize (Comp) <= Max_Machine_Scalar_Size + then + Num_CC := Num_CC + 1; + Comps (Num_CC) := Comp; end if; - end if; - Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); - Set_Normalized_First_Bit (Comp, NFB mod SSU); - end; - end loop; - end loop; - end; + Next_Component_Or_Discriminant (Comp); + end loop; + + -- Sort by ascending position number + + Sorting.Sort (Num_CC); + + -- We now have all the components whose size does not exceed + -- the max machine scalar value, sorted by starting + -- position. In this loop we gather groups of clauses + -- starting at the same position, to process them in + -- accordance with Ada 2005 AI-133. + + Stop := 0; + while Stop < Num_CC loop + Start := Stop + 1; + Stop := Start; + MaxL := + Static_Integer + (Last_Bit (Component_Clause (Comps (Start)))); + while Stop < Num_CC loop + if Static_Integer + (Position (Component_Clause (Comps (Stop + 1)))) = + Static_Integer + (Position (Component_Clause (Comps (Stop)))) + then + Stop := Stop + 1; + MaxL := + UI_Max + (MaxL, + Static_Integer + (Last_Bit + (Component_Clause (Comps (Stop))))); + else + exit; + end if; + end loop; + + -- Now we have a group of component clauses from Start to + -- Stop whose positions are identical, and MaxL is the + -- maximum last bit value of any of these components. + + -- We need to determine the corresponding machine scalar + -- size. This loop assumes that machine scalar sizes are + -- even, and that each possible machine scalar has twice + -- as many bits as the next smaller one. + + MSS := Max_Machine_Scalar_Size; + while MSS mod 2 = 0 + and then (MSS / 2) >= SSU + and then (MSS / 2) > MaxL + loop + MSS := MSS / 2; + end loop; + + -- Here is where we fix up the Component_Bit_Offset value + -- to account for the reverse bit order. Some examples of + -- what needs to be done for the case of a machine scalar + -- size of 8 are: + + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new + + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 + + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 + + -- The general rule is that the first bit is obtained by + -- subtracting the old ending bit from machine scalar + -- size - 1. + + for C in Start .. Stop loop + declare + Comp : constant Entity_Id := Comps (C); + CC : constant Node_Id := + Component_Clause (Comp); + LB : constant Uint := + Static_Integer (Last_Bit (CC)); + NFB : constant Uint := MSS - Uint_1 - LB; + NLB : constant Uint := NFB + Esize (Comp) - 1; + Pos : constant Uint := + Static_Integer (Position (CC)); + + begin + if Warn_On_Reverse_Bit_Order then + Error_Msg_Uint_1 := MSS; + Error_Msg_N + ("info: reverse bit order in machine " & + "scalar of length^?", First_Bit (CC)); + Error_Msg_Uint_1 := NFB; + Error_Msg_Uint_2 := NLB; + + if Bytes_Big_Endian then + Error_Msg_NE + ("?\info: big-endian range for " + & "component & is ^ .. ^", + First_Bit (CC), Comp); + else + Error_Msg_NE + ("?\info: little-endian range " + & "for component & is ^ .. ^", + First_Bit (CC), Comp); + end if; + end if; + + Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); + Set_Normalized_First_Bit (Comp, NFB mod SSU); + end; + end loop; + end loop; + end Sort_CC; + end; + end case; end Adjust_Record_For_Reverse_Bit_Order; -------------------------------------- @@ -2233,11 +2385,16 @@ package body Sem_Ch13 is -- Analyze_Record_Representation_Clause -- ------------------------------------------ + -- Note: we check as much as we can here, but we can't do any checks + -- based on the position values (e.g. overlap checks) until freeze time + -- because especially in Ada 2005 (machine scalar mode), the processing + -- for non-standard bit order can substantially change the positions. + -- See procedure Check_Record_Representation_Clause (called from Freeze) + -- for the remainder of this processing. + procedure Analyze_Record_Representation_Clause (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); Ident : constant Node_Id := Identifier (N); Rectype : Entity_Id; - Fent : Entity_Id; CC : Node_Id; Posit : Uint; Fbit : Uint; @@ -2245,33 +2402,8 @@ package body Sem_Ch13 is Hbit : Uint := Uint_0; Comp : Entity_Id; Ocomp : Entity_Id; - Pcomp : Entity_Id; Biased : Boolean; - Max_Bit_So_Far : Uint; - -- Records the maximum bit position so far. If all field positions - -- are monotonically increasing, then we can skip the circuit for - -- checking for overlap, since no overlap is possible. - - Tagged_Parent : Entity_Id := Empty; - -- This is set in the case of a derived tagged type for which we have - -- Is_Fully_Repped_Tagged_Type True (indicating that all components are - -- positioned by record representation clauses). In this case we must - -- check for overlap between components of this tagged type, and the - -- components of its parent. Tagged_Parent will point to this parent - -- type. For all other cases Tagged_Parent is left set to Empty. - - Parent_Last_Bit : Uint; - -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the - -- last bit position for any field in the parent type. We only need to - -- check overlap for fields starting below this point. - - Overlap_Check_Required : Boolean; - -- Used to keep track of whether or not an overlap check is required - - Ccount : Natural := 0; - -- Number of component clauses in record rep clause - CR_Pragma : Node_Id := Empty; -- Points to N_Pragma node if Complete_Representation pragma present @@ -2386,36 +2518,6 @@ package body Sem_Ch13 is end loop; end if; - -- See if we have a fully repped derived tagged type - - declare - PS : constant Entity_Id := Parent_Subtype (Rectype); - - begin - if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then - Tagged_Parent := PS; - - -- Find maximum bit of any component of the parent type - - Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); - Pcomp := First_Entity (Tagged_Parent); - while Present (Pcomp) loop - if Ekind_In (Pcomp, E_Discriminant, E_Component) then - if Component_Bit_Offset (Pcomp) /= No_Uint - and then Known_Static_Esize (Pcomp) - then - Parent_Last_Bit := - UI_Max - (Parent_Last_Bit, - Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); - end if; - - Next_Entity (Pcomp); - end if; - end loop; - end if; - end; - -- All done if no component clauses CC := First (Component_Clauses (N)); @@ -2424,51 +2526,12 @@ package body Sem_Ch13 is return; end if; - -- If a tag is present, then create a component clause that places it - -- at the start of the record (otherwise gigi may place it after other - -- fields that have rep clauses). - - Fent := First_Entity (Rectype); - - if Nkind (Fent) = N_Defining_Identifier - and then Chars (Fent) = Name_uTag - then - Set_Component_Bit_Offset (Fent, Uint_0); - Set_Normalized_Position (Fent, Uint_0); - Set_Normalized_First_Bit (Fent, Uint_0); - Set_Normalized_Position_Max (Fent, Uint_0); - Init_Esize (Fent, System_Address_Size); - - Set_Component_Clause (Fent, - Make_Component_Clause (Loc, - Component_Name => - Make_Identifier (Loc, - Chars => Name_uTag), - - Position => - Make_Integer_Literal (Loc, - Intval => Uint_0), - - First_Bit => - Make_Integer_Literal (Loc, - Intval => Uint_0), - - Last_Bit => - Make_Integer_Literal (Loc, - UI_From_Int (System_Address_Size)))); - - Ccount := Ccount + 1; - end if; - -- A representation like this applies to the base type Set_Has_Record_Rep_Clause (Base_Type (Rectype)); Set_Has_Non_Standard_Rep (Base_Type (Rectype)); Set_Has_Specified_Layout (Base_Type (Rectype)); - Max_Bit_So_Far := Uint_Minus_1; - Overlap_Check_Required := False; - -- Process the component clauses while Present (CC) loop @@ -2487,7 +2550,6 @@ package body Sem_Ch13 is -- Processing for real component clause else - Ccount := Ccount + 1; Posit := Static_Integer (Position (CC)); Fbit := Static_Integer (First_Bit (CC)); Lbit := Static_Integer (Last_Bit (CC)); @@ -2596,12 +2658,6 @@ package body Sem_Ch13 is Fbit := Fbit + UI_From_Int (SSU) * Posit; Lbit := Lbit + UI_From_Int (SSU) * Posit; - if Fbit <= Max_Bit_So_Far then - Overlap_Check_Required := True; - else - Max_Bit_So_Far := Lbit; - end if; - if Has_Size_Clause (Rectype) and then Esize (Rectype) <= Lbit then @@ -2615,17 +2671,6 @@ package body Sem_Ch13 is Set_Normalized_First_Bit (Comp, Fbit mod SSU); Set_Normalized_Position (Comp, Fbit / SSU); - Set_Normalized_Position_Max - (Fent, Normalized_Position (Fent)); - - if Is_Tagged_Type (Rectype) - and then Fbit < System_Address_Size - then - Error_Msg_NE - ("component overlaps tag field of&", - Component_Name (CC), Rectype); - end if; - -- This information is also set in the corresponding -- component of the base type, found by accessing the -- Original_Record_Component link if it is present. @@ -2668,27 +2713,6 @@ package body Sem_Ch13 is Error_Msg_N ("component size is negative", CC); end if; end if; - - -- If OK component size, check parent type overlap if - -- this component might overlap a parent field. - - if Present (Tagged_Parent) - and then Fbit <= Parent_Last_Bit - then - Pcomp := First_Entity (Tagged_Parent); - while Present (Pcomp) loop - if (Ekind (Pcomp) = E_Discriminant - or else - Ekind (Pcomp) = E_Component) - and then not Is_Tag (Pcomp) - and then Chars (Pcomp) /= Name_uParent - then - Check_Component_Overlap (Comp, Pcomp); - end if; - - Next_Entity (Pcomp); - end loop; - end if; end if; end if; end if; @@ -2697,252 +2721,6 @@ package body Sem_Ch13 is Next (CC); end loop; - -- Now that we have processed all the component clauses, check for - -- overlap. We have to leave this till last, since the components can - -- appear in any arbitrary order in the representation clause. - - -- We do not need this check if all specified ranges were monotonic, - -- as recorded by Overlap_Check_Required being False at this stage. - - -- This first section checks if there are any overlapping entries at - -- all. It does this by sorting all entries and then seeing if there are - -- any overlaps. If there are none, then that is decisive, but if there - -- are overlaps, they may still be OK (they may result from fields in - -- different variants). - - if Overlap_Check_Required then - Overlap_Check1 : declare - - OC_Fbit : array (0 .. Ccount) of Uint; - -- First-bit values for component clauses, the value is the offset - -- of the first bit of the field from start of record. The zero - -- entry is for use in sorting. - - OC_Lbit : array (0 .. Ccount) of Uint; - -- Last-bit values for component clauses, the value is the offset - -- of the last bit of the field from start of record. The zero - -- entry is for use in sorting. - - OC_Count : Natural := 0; - -- Count of entries in OC_Fbit and OC_Lbit - - function OC_Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort - - procedure OC_Move (From : Natural; To : Natural); - -- Move routine for Sort - - package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); - - ----------- - -- OC_Lt -- - ----------- - - function OC_Lt (Op1, Op2 : Natural) return Boolean is - begin - return OC_Fbit (Op1) < OC_Fbit (Op2); - end OC_Lt; - - ------------- - -- OC_Move -- - ------------- - - procedure OC_Move (From : Natural; To : Natural) is - begin - OC_Fbit (To) := OC_Fbit (From); - OC_Lbit (To) := OC_Lbit (From); - end OC_Move; - - -- Start of processing for Overlap_Check - - begin - CC := First (Component_Clauses (N)); - while Present (CC) loop - if Nkind (CC) /= N_Pragma then - Posit := Static_Integer (Position (CC)); - Fbit := Static_Integer (First_Bit (CC)); - Lbit := Static_Integer (Last_Bit (CC)); - - if Posit /= No_Uint - and then Fbit /= No_Uint - and then Lbit /= No_Uint - then - OC_Count := OC_Count + 1; - Posit := Posit * SSU; - OC_Fbit (OC_Count) := Fbit + Posit; - OC_Lbit (OC_Count) := Lbit + Posit; - end if; - end if; - - Next (CC); - end loop; - - Sorting.Sort (OC_Count); - - Overlap_Check_Required := False; - for J in 1 .. OC_Count - 1 loop - if OC_Lbit (J) >= OC_Fbit (J + 1) then - Overlap_Check_Required := True; - exit; - end if; - end loop; - end Overlap_Check1; - end if; - - -- If Overlap_Check_Required is still True, then we have to do the full - -- scale overlap check, since we have at least two fields that do - -- overlap, and we need to know if that is OK since they are in - -- different variant, or whether we have a definite problem. - - if Overlap_Check_Required then - Overlap_Check2 : declare - C1_Ent, C2_Ent : Entity_Id; - -- Entities of components being checked for overlap - - Clist : Node_Id; - -- Component_List node whose Component_Items are being checked - - Citem : Node_Id; - -- Component declaration for component being checked - - begin - C1_Ent := First_Entity (Base_Type (Rectype)); - - -- Loop through all components in record. For each component check - -- for overlap with any of the preceding elements on the component - -- list containing the component and also, if the component is in - -- a variant, check against components outside the case structure. - -- This latter test is repeated recursively up the variant tree. - - Main_Component_Loop : while Present (C1_Ent) loop - if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then - goto Continue_Main_Component_Loop; - end if; - - -- Skip overlap check if entity has no declaration node. This - -- happens with discriminants in constrained derived types. - -- Probably we are missing some checks as a result, but that - -- does not seem terribly serious ??? - - if No (Declaration_Node (C1_Ent)) then - goto Continue_Main_Component_Loop; - end if; - - Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); - - -- Loop through component lists that need checking. Check the - -- current component list and all lists in variants above us. - - Component_List_Loop : loop - - -- If derived type definition, go to full declaration - -- If at outer level, check discriminants if there are any. - - if Nkind (Clist) = N_Derived_Type_Definition then - Clist := Parent (Clist); - end if; - - -- Outer level of record definition, check discriminants - - if Nkind_In (Clist, N_Full_Type_Declaration, - N_Private_Type_Declaration) - then - if Has_Discriminants (Defining_Identifier (Clist)) then - C2_Ent := - First_Discriminant (Defining_Identifier (Clist)); - while Present (C2_Ent) loop - exit when C1_Ent = C2_Ent; - Check_Component_Overlap (C1_Ent, C2_Ent); - Next_Discriminant (C2_Ent); - end loop; - end if; - - -- Record extension case - - elsif Nkind (Clist) = N_Derived_Type_Definition then - Clist := Empty; - - -- Otherwise check one component list - - else - Citem := First (Component_Items (Clist)); - - while Present (Citem) loop - if Nkind (Citem) = N_Component_Declaration then - C2_Ent := Defining_Identifier (Citem); - exit when C1_Ent = C2_Ent; - Check_Component_Overlap (C1_Ent, C2_Ent); - end if; - - Next (Citem); - end loop; - end if; - - -- Check for variants above us (the parent of the Clist can - -- be a variant, in which case its parent is a variant part, - -- and the parent of the variant part is a component list - -- whose components must all be checked against the current - -- component for overlap). - - if Nkind (Parent (Clist)) = N_Variant then - Clist := Parent (Parent (Parent (Clist))); - - -- Check for possible discriminant part in record, this is - -- treated essentially as another level in the recursion. - -- For this case the parent of the component list is the - -- record definition, and its parent is the full type - -- declaration containing the discriminant specifications. - - elsif Nkind (Parent (Clist)) = N_Record_Definition then - Clist := Parent (Parent ((Clist))); - - -- If neither of these two cases, we are at the top of - -- the tree. - - else - exit Component_List_Loop; - end if; - end loop Component_List_Loop; - - <<Continue_Main_Component_Loop>> - Next_Entity (C1_Ent); - - end loop Main_Component_Loop; - end Overlap_Check2; - end if; - - -- For records that have component clauses for all components, and whose - -- size is less than or equal to 32, we need to know the size in the - -- front end to activate possible packed array processing where the - -- component type is a record. - - -- At this stage Hbit + 1 represents the first unused bit from all the - -- component clauses processed, so if the component clauses are - -- complete, then this is the length of the record. - - -- For records longer than System.Storage_Unit, and for those where not - -- all components have component clauses, the back end determines the - -- length (it may for example be appropriate to round up the size - -- to some convenient boundary, based on alignment considerations, etc). - - if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then - - -- Nothing to do if at least one component has no component clause - - Comp := First_Component_Or_Discriminant (Rectype); - while Present (Comp) loop - exit when No (Component_Clause (Comp)); - Next_Component_Or_Discriminant (Comp); - end loop; - - -- If we fall out of loop, all components have component clauses - -- and so we can set the size to the maximum value. - - if No (Comp) then - Set_RM_Size (Rectype, Hbit + 1); - end if; - end if; - -- Check missing components if Complete_Representation pragma appeared if Present (CR_Pragma) then @@ -2956,7 +2734,7 @@ package body Sem_Ch13 is Next_Component_Or_Discriminant (Comp); end loop; - -- If no Complete_Representation pragma, warn if missing components + -- If no Complete_Representation pragma, warn if missing components elsif Warn_On_Unrepped_Components then declare @@ -2994,8 +2772,8 @@ package body Sem_Ch13 is and then Comes_From_Source (Comp) and then Present (Underlying_Type (Etype (Comp))) and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) - or else Size_Known_At_Compile_Time - (Underlying_Type (Etype (Comp)))) + or else Size_Known_At_Compile_Time + (Underlying_Type (Etype (Comp)))) and then not Has_Warnings_Off (Rectype) then Error_Msg_Sloc := Sloc (Comp); @@ -3011,50 +2789,6 @@ package body Sem_Ch13 is end if; end Analyze_Record_Representation_Clause; - ----------------------------- - -- Check_Component_Overlap -- - ----------------------------- - - procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is - begin - if Present (Component_Clause (C1_Ent)) - and then Present (Component_Clause (C2_Ent)) - then - -- Exclude odd case where we have two tag fields in the same record, - -- both at location zero. This seems a bit strange, but it seems to - -- happen in some circumstances ??? - - if Chars (C1_Ent) = Name_uTag - and then Chars (C2_Ent) = Name_uTag - then - return; - end if; - - -- Here we check if the two fields overlap - - declare - S1 : constant Uint := Component_Bit_Offset (C1_Ent); - S2 : constant Uint := Component_Bit_Offset (C2_Ent); - E1 : constant Uint := S1 + Esize (C1_Ent); - E2 : constant Uint := S2 + Esize (C2_Ent); - - begin - if E2 <= S1 or else E1 <= S2 then - null; - else - Error_Msg_Node_2 := - Component_Name (Component_Clause (C2_Ent)); - Error_Msg_Sloc := Sloc (Error_Msg_Node_2); - Error_Msg_Node_1 := - Component_Name (Component_Clause (C1_Ent)); - Error_Msg_N - ("component& overlaps & #", - Component_Name (Component_Clause (C1_Ent))); - end if; - end; - end if; - end Check_Component_Overlap; - ----------------------------------- -- Check_Constant_Address_Clause -- ----------------------------------- @@ -3401,6 +3135,566 @@ package body Sem_Ch13 is Check_Expr_Constants (Expr); end Check_Constant_Address_Clause; + ---------------------------------------- + -- Check_Record_Representation_Clause -- + ---------------------------------------- + + procedure Check_Record_Representation_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ident : constant Node_Id := Identifier (N); + Rectype : Entity_Id; + Fent : Entity_Id; + CC : Node_Id; + Fbit : Uint; + Lbit : Uint; + Hbit : Uint := Uint_0; + Comp : Entity_Id; + Pcomp : Entity_Id; + + Max_Bit_So_Far : Uint; + -- Records the maximum bit position so far. If all field positions + -- are monotonically increasing, then we can skip the circuit for + -- checking for overlap, since no overlap is possible. + + Tagged_Parent : Entity_Id := Empty; + -- This is set in the case of a derived tagged type for which we have + -- Is_Fully_Repped_Tagged_Type True (indicating that all components are + -- positioned by record representation clauses). In this case we must + -- check for overlap between components of this tagged type, and the + -- components of its parent. Tagged_Parent will point to this parent + -- type. For all other cases Tagged_Parent is left set to Empty. + + Parent_Last_Bit : Uint; + -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the + -- last bit position for any field in the parent type. We only need to + -- check overlap for fields starting below this point. + + Overlap_Check_Required : Boolean; + -- Used to keep track of whether or not an overlap check is required + + Ccount : Natural := 0; + -- Number of component clauses in record rep clause + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); + -- Given two entities for record components or discriminants, checks + -- if they have overlapping component clauses and issues errors if so. + + procedure Find_Component; + -- Finds component entity corresponding to current component clause (in + -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin + -- start/stop bits for the field. If there is no matching component or + -- if the matching component does not have a component clause, then + -- that's an error and Comp is set to Empty, but no error message is + -- issued, since the message was already given. Comp is also set to + -- Empty if the current "component clause" is in fact a pragma. + + ----------------------------- + -- Check_Component_Overlap -- + ----------------------------- + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is + CC1 : constant Node_Id := Component_Clause (C1_Ent); + CC2 : constant Node_Id := Component_Clause (C2_Ent); + begin + if Present (CC1) and then Present (CC2) then + + -- Exclude odd case where we have two tag fields in the same + -- record, both at location zero. This seems a bit strange, but + -- it seems to happen in some circumstances, perhaps on an error. + + if Chars (C1_Ent) = Name_uTag + and then + Chars (C2_Ent) = Name_uTag + then + return; + end if; + + -- Here we check if the two fields overlap + + declare + S1 : constant Uint := Component_Bit_Offset (C1_Ent); + S2 : constant Uint := Component_Bit_Offset (C2_Ent); + E1 : constant Uint := S1 + Esize (C1_Ent); + E2 : constant Uint := S2 + Esize (C2_Ent); + + begin + if E2 <= S1 or else E1 <= S2 then + null; + else + Error_Msg_Node_2 := Component_Name (CC2); + Error_Msg_Sloc := Sloc (Error_Msg_Node_2); + Error_Msg_Node_1 := Component_Name (CC1); + Error_Msg_N + ("component& overlaps & #", Component_Name (CC1)); + end if; + end; + end if; + end Check_Component_Overlap; + + -------------------- + -- Find_Component -- + -------------------- + + procedure Find_Component is + + procedure Search_Component (R : Entity_Id); + -- Search components of R for a match. If found, Comp is set. + + ---------------------- + -- Search_Component -- + ---------------------- + + procedure Search_Component (R : Entity_Id) is + begin + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + + -- Ignore error of attribute name for component name (we + -- already gave an error message for this, so no need to + -- complain here) + + if Nkind (Component_Name (CC)) = N_Attribute_Reference then + null; + else + exit when Chars (Comp) = Chars (Component_Name (CC)); + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end Search_Component; + + -- Start of processing for Find_Component + + begin + -- Return with Comp set to Empty if we have a pragma + + if Nkind (CC) = N_Pragma then + Comp := Empty; + return; + end if; + + -- Search current record for matching component + + Search_Component (Rectype); + + -- If not found, maybe component of base type that is absent from + -- statically constrained first subtype. + + if No (Comp) then + Search_Component (Base_Type (Rectype)); + end if; + + -- If no component, or the component does not reference the component + -- clause in question, then there was some previous error for which + -- we already gave a message, so just return with Comp Empty. + + if No (Comp) + or else Component_Clause (Comp) /= CC + then + Comp := Empty; + + -- Normal case where we have a component clause + + else + Fbit := Component_Bit_Offset (Comp); + Lbit := Fbit + Esize (Comp) - 1; + end if; + end Find_Component; + + -- Start of processing for Check_Record_Representation_Clause + + begin + Find_Type (Ident); + Rectype := Entity (Ident); + + if Rectype = Any_Type then + return; + else + Rectype := Underlying_Type (Rectype); + end if; + + -- See if we have a fully repped derived tagged type + + declare + PS : constant Entity_Id := Parent_Subtype (Rectype); + + begin + if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then + Tagged_Parent := PS; + + -- Find maximum bit of any component of the parent type + + Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); + Pcomp := First_Entity (Tagged_Parent); + while Present (Pcomp) loop + if Ekind_In (Pcomp, E_Discriminant, E_Component) then + if Component_Bit_Offset (Pcomp) /= No_Uint + and then Known_Static_Esize (Pcomp) + then + Parent_Last_Bit := + UI_Max + (Parent_Last_Bit, + Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); + end if; + + Next_Entity (Pcomp); + end if; + end loop; + end if; + end; + + -- All done if no component clauses + + CC := First (Component_Clauses (N)); + + if No (CC) then + return; + end if; + + -- If a tag is present, then create a component clause that places it + -- at the start of the record (otherwise gigi may place it after other + -- fields that have rep clauses). + + Fent := First_Entity (Rectype); + + if Nkind (Fent) = N_Defining_Identifier + and then Chars (Fent) = Name_uTag + then + Set_Component_Bit_Offset (Fent, Uint_0); + Set_Normalized_Position (Fent, Uint_0); + Set_Normalized_First_Bit (Fent, Uint_0); + Set_Normalized_Position_Max (Fent, Uint_0); + Init_Esize (Fent, System_Address_Size); + + Set_Component_Clause (Fent, + Make_Component_Clause (Loc, + Component_Name => + Make_Identifier (Loc, + Chars => Name_uTag), + + Position => + Make_Integer_Literal (Loc, + Intval => Uint_0), + + First_Bit => + Make_Integer_Literal (Loc, + Intval => Uint_0), + + Last_Bit => + Make_Integer_Literal (Loc, + UI_From_Int (System_Address_Size)))); + + Ccount := Ccount + 1; + end if; + + Max_Bit_So_Far := Uint_Minus_1; + Overlap_Check_Required := False; + + -- Process the component clauses + + while Present (CC) loop + Find_Component; + + if Present (Comp) then + Ccount := Ccount + 1; + + if Fbit <= Max_Bit_So_Far then + Overlap_Check_Required := True; + else + Max_Bit_So_Far := Lbit; + end if; + + -- Check bit position out of range of specified size + + if Has_Size_Clause (Rectype) + and then Esize (Rectype) <= Lbit + then + Error_Msg_N + ("bit number out of range of specified size", + Last_Bit (CC)); + + -- Check for overlap with tag field + + else + if Is_Tagged_Type (Rectype) + and then Fbit < System_Address_Size + then + Error_Msg_NE + ("component overlaps tag field of&", + Component_Name (CC), Rectype); + end if; + + if Hbit < Lbit then + Hbit := Lbit; + end if; + end if; + + -- Check parent overlap if component might overlap parent field + + if Present (Tagged_Parent) + and then Fbit <= Parent_Last_Bit + then + Pcomp := First_Component_Or_Discriminant (Tagged_Parent); + while Present (Pcomp) loop + if not Is_Tag (Pcomp) + and then Chars (Pcomp) /= Name_uParent + then + Check_Component_Overlap (Comp, Pcomp); + end if; + + Next_Component_Or_Discriminant (Pcomp); + end loop; + end if; + end if; + + Next (CC); + end loop; + + -- Now that we have processed all the component clauses, check for + -- overlap. We have to leave this till last, since the components can + -- appear in any arbitrary order in the representation clause. + + -- We do not need this check if all specified ranges were monotonic, + -- as recorded by Overlap_Check_Required being False at this stage. + + -- This first section checks if there are any overlapping entries at + -- all. It does this by sorting all entries and then seeing if there are + -- any overlaps. If there are none, then that is decisive, but if there + -- are overlaps, they may still be OK (they may result from fields in + -- different variants). + + if Overlap_Check_Required then + Overlap_Check1 : declare + + OC_Fbit : array (0 .. Ccount) of Uint; + -- First-bit values for component clauses, the value is the offset + -- of the first bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Lbit : array (0 .. Ccount) of Uint; + -- Last-bit values for component clauses, the value is the offset + -- of the last bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Count : Natural := 0; + -- Count of entries in OC_Fbit and OC_Lbit + + function OC_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure OC_Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); + + ----------- + -- OC_Lt -- + ----------- + + function OC_Lt (Op1, Op2 : Natural) return Boolean is + begin + return OC_Fbit (Op1) < OC_Fbit (Op2); + end OC_Lt; + + ------------- + -- OC_Move -- + ------------- + + procedure OC_Move (From : Natural; To : Natural) is + begin + OC_Fbit (To) := OC_Fbit (From); + OC_Lbit (To) := OC_Lbit (From); + end OC_Move; + + -- Start of processing for Overlap_Check + + begin + CC := First (Component_Clauses (N)); + while Present (CC) loop + + -- Exclude component clause already marked in error + + if not Error_Posted (CC) then + Find_Component; + + if Present (Comp) then + OC_Count := OC_Count + 1; + OC_Fbit (OC_Count) := Fbit; + OC_Lbit (OC_Count) := Lbit; + end if; + end if; + + Next (CC); + end loop; + + Sorting.Sort (OC_Count); + + Overlap_Check_Required := False; + for J in 1 .. OC_Count - 1 loop + if OC_Lbit (J) >= OC_Fbit (J + 1) then + Overlap_Check_Required := True; + exit; + end if; + end loop; + end Overlap_Check1; + end if; + + -- If Overlap_Check_Required is still True, then we have to do the full + -- scale overlap check, since we have at least two fields that do + -- overlap, and we need to know if that is OK since they are in + -- different variant, or whether we have a definite problem. + + if Overlap_Check_Required then + Overlap_Check2 : declare + C1_Ent, C2_Ent : Entity_Id; + -- Entities of components being checked for overlap + + Clist : Node_Id; + -- Component_List node whose Component_Items are being checked + + Citem : Node_Id; + -- Component declaration for component being checked + + begin + C1_Ent := First_Entity (Base_Type (Rectype)); + + -- Loop through all components in record. For each component check + -- for overlap with any of the preceding elements on the component + -- list containing the component and also, if the component is in + -- a variant, check against components outside the case structure. + -- This latter test is repeated recursively up the variant tree. + + Main_Component_Loop : while Present (C1_Ent) loop + if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then + goto Continue_Main_Component_Loop; + end if; + + -- Skip overlap check if entity has no declaration node. This + -- happens with discriminants in constrained derived types. + -- Probably we are missing some checks as a result, but that + -- does not seem terribly serious ??? + + if No (Declaration_Node (C1_Ent)) then + goto Continue_Main_Component_Loop; + end if; + + Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); + + -- Loop through component lists that need checking. Check the + -- current component list and all lists in variants above us. + + Component_List_Loop : loop + + -- If derived type definition, go to full declaration + -- If at outer level, check discriminants if there are any. + + if Nkind (Clist) = N_Derived_Type_Definition then + Clist := Parent (Clist); + end if; + + -- Outer level of record definition, check discriminants + + if Nkind_In (Clist, N_Full_Type_Declaration, + N_Private_Type_Declaration) + then + if Has_Discriminants (Defining_Identifier (Clist)) then + C2_Ent := + First_Discriminant (Defining_Identifier (Clist)); + while Present (C2_Ent) loop + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + Next_Discriminant (C2_Ent); + end loop; + end if; + + -- Record extension case + + elsif Nkind (Clist) = N_Derived_Type_Definition then + Clist := Empty; + + -- Otherwise check one component list + + else + Citem := First (Component_Items (Clist)); + + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + C2_Ent := Defining_Identifier (Citem); + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + end if; + + Next (Citem); + end loop; + end if; + + -- Check for variants above us (the parent of the Clist can + -- be a variant, in which case its parent is a variant part, + -- and the parent of the variant part is a component list + -- whose components must all be checked against the current + -- component for overlap). + + if Nkind (Parent (Clist)) = N_Variant then + Clist := Parent (Parent (Parent (Clist))); + + -- Check for possible discriminant part in record, this + -- is treated essentially as another level in the + -- recursion. For this case the parent of the component + -- list is the record definition, and its parent is the + -- full type declaration containing the discriminant + -- specifications. + + elsif Nkind (Parent (Clist)) = N_Record_Definition then + Clist := Parent (Parent ((Clist))); + + -- If neither of these two cases, we are at the top of + -- the tree. + + else + exit Component_List_Loop; + end if; + end loop Component_List_Loop; + + <<Continue_Main_Component_Loop>> + Next_Entity (C1_Ent); + + end loop Main_Component_Loop; + end Overlap_Check2; + end if; + + -- For records that have component clauses for all components, and whose + -- size is less than or equal to 32, we need to know the size in the + -- front end to activate possible packed array processing where the + -- component type is a record. + + -- At this stage Hbit + 1 represents the first unused bit from all the + -- component clauses processed, so if the component clauses are + -- complete, then this is the length of the record. + + -- For records longer than System.Storage_Unit, and for those where not + -- all components have component clauses, the back end determines the + -- length (it may for example be appropriate to round up the size + -- to some convenient boundary, based on alignment considerations, etc). + + if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then + + -- Nothing to do if at least one component has no component clause + + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + exit when No (Component_Clause (Comp)); + Next_Component_Or_Discriminant (Comp); + end loop; + + -- If we fall out of loop, all components have component clauses + -- and so we can set the size to the maximum value. + + if No (Comp) then + Set_RM_Size (Rectype, Hbit + 1); + end if; + end if; + end Check_Record_Representation_Clause; + ---------------- -- Check_Size -- ---------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 93587fd..b95eed6 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -38,9 +38,17 @@ package Sem_Ch13 is procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id); -- Called from Freeze where R is a record entity for which reverse bit -- order is specified and there is at least one component clause. Adjusts - -- component positions according to Ada 2005 AI-133. Note that this is only - -- called in Ada 2005 mode. The Ada 95 handling for bit order is entirely - -- contained in Freeze. + -- component positions according to either Ada 95 or Ada 2005 (AI-133). + + procedure Check_Record_Representation_Clause (N : Node_Id); + -- This procedure completes the analysis of a record representation clause + -- N. It is called at freeze time after adjustment of component clause bit + -- positions for possible non-standard bit order. In the case of Ada 2005 + -- (machine scalar) mode, this adjustment can make substantial changes, so + -- some checks, in particular for component overlaps cannot be done at the + -- time the record representation clause is first seen, but must be delayed + -- till freeze time, and in particular is called after calling the above + -- procedure for adjusting record bit positions for reverse bit order. procedure Initialize; -- Initialize internal tables for new compilation diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 13bbdef..c16ef14 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -2534,9 +2534,9 @@ package body Sem_Eval is -- Eval_Relational_Op -- ------------------------ - -- Relational operations are static functions, so the result is static - -- if both operands are static (RM 4.9(7), 4.9(20)), except that for - -- strings, the result is never static, even if the operands are. + -- Relational operations are static functions, so the result is static if + -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings, + -- the result is never static, even if the operands are. procedure Eval_Relational_Op (N : Node_Id) is Left : constant Node_Id := Left_Opnd (N); @@ -2650,17 +2650,37 @@ package body Sem_Eval is if Nkind (Expr) = N_Op_Add and then Compile_Time_Known_Value (Right_Opnd (Expr)) then - Exp := Left_Opnd (Expr); + Exp := Left_Opnd (Expr); Cons := Expr_Value (Right_Opnd (Expr)); elsif Nkind (Expr) = N_Op_Subtract and then Compile_Time_Known_Value (Right_Opnd (Expr)) then - Exp := Left_Opnd (Expr); + Exp := Left_Opnd (Expr); Cons := -Expr_Value (Right_Opnd (Expr)); + -- If the bound is a constant created to remove side + -- effects, recover original expression to see if it has + -- one of the recognizable forms. + + elsif Nkind (Expr) = N_Identifier + and then not Comes_From_Source (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_Constant + and then + Nkind (Parent (Entity (Expr))) = N_Object_Declaration + then + Exp := Expression (Parent (Entity (Expr))); + Decompose_Expr (Exp, Ent, Kind, Cons); + + -- If original expression includes an entity, create a + -- reference to it for use below. + + if Present (Ent) then + Exp := New_Occurrence_Of (Ent, Sloc (Ent)); + end if; + else - Exp := Expr; + Exp := Expr; Cons := Uint_0; end if; @@ -2669,8 +2689,10 @@ package body Sem_Eval is if Nkind (Exp) = N_Attribute_Reference then if Attribute_Name (Exp) = Name_First then Kind := 'F'; + elsif Attribute_Name (Exp) = Name_Last then Kind := 'L'; + else Ent := Empty; return; diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 42136b1..2fb0999 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -73,9 +73,7 @@ package body Sem_Intr is procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is begin - if Ekind (E) /= E_Function - and then Ekind (E) /= E_Generic_Function - then + if not Ekind_In (E, E_Function, E_Generic_Function) then Errint ("intrinsic exception subprogram must be a function", E, N); @@ -374,9 +372,7 @@ package body Sem_Intr is Ptyp2 : Node_Id; begin - if Ekind (E) /= E_Function - and then Ekind (E) /= E_Generic_Function - then + if not Ekind_In (E, E_Function, E_Generic_Function) then Errint ("intrinsic shift subprogram must be a function", E, N); return; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 147a920..29c7067 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1846,7 +1846,8 @@ package body Sem_Prag is Proc := Entity (Name); if Ekind (Proc) /= E_Procedure - or else Present (First_Formal (Proc)) then + or else Present (First_Formal (Proc)) + then Error_Pragma_Arg ("argument of pragma% must be parameterless procedure", Arg); end if; @@ -2516,10 +2517,7 @@ package body Sem_Prag is -- Check that we are not applying this to a named constant - if Ekind (E) = E_Named_Integer - or else - Ekind (E) = E_Named_Real - then + if Ekind_In (E, E_Named_Integer, E_Named_Real) then Error_Msg_Name_1 := Pname; Error_Msg_N ("cannot apply pragma% to named constant!", @@ -2756,9 +2754,7 @@ package body Sem_Prag is Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Def_Id := Entity (Arg_Internal); - if Ekind (Def_Id) /= E_Constant - and then Ekind (Def_Id) /= E_Variable - then + if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Arg_Internal); end if; @@ -3368,10 +3364,8 @@ package body Sem_Prag is Kill_Size_Check_Code (Def_Id); Note_Possible_Modification (Expression (Arg2), Sure => False); - if Ekind (Def_Id) = E_Variable - or else - Ekind (Def_Id) = E_Constant - then + if Ekind_In (Def_Id, E_Variable, E_Constant) then + -- We do not permit Import to apply to a renaming declaration if Present (Renamed_Object (Def_Id)) then @@ -9131,9 +9125,7 @@ package body Sem_Prag is while Present (E) and then Scope (E) = Current_Scope loop - if Ekind (E) = E_Procedure - or else Ekind (E) = E_Generic_Procedure - then + if Ekind_In (E, E_Procedure, E_Generic_Procedure) then Set_No_Return (E); -- Set flag on any alias as well @@ -10291,9 +10283,7 @@ package body Sem_Prag is Def_Id := Entity (Internal); - if Ekind (Def_Id) /= E_Constant - and then Ekind (Def_Id) /= E_Variable - then + if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Internal); end if; @@ -10459,9 +10449,9 @@ package body Sem_Prag is loop Def_Id := Get_Base_Subprogram (E); - if Ekind (Def_Id) /= E_Function - and then Ekind (Def_Id) /= E_Generic_Function - and then Ekind (Def_Id) /= E_Operator + if not Ekind_In (Def_Id, E_Function, + E_Generic_Function, + E_Operator) then Error_Pragma_Arg ("pragma% requires a function name", Arg1); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 24980c1..ef5e3ad 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3534,9 +3534,7 @@ package body Sem_Res is -- might not be done in the In Out case since Gigi does not do -- any analysis. More thought required about this ??? - if Ekind (F) = E_In_Parameter - or else Ekind (F) = E_In_Out_Parameter - then + if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then if Is_Scalar_Type (Etype (A)) then Apply_Scalar_Range_Check (A, F_Typ); @@ -3582,9 +3580,7 @@ package body Sem_Res is end if; end if; - if Ekind (F) = E_Out_Parameter - or else Ekind (F) = E_In_Out_Parameter - then + if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then if Nkind (A) = N_Type_Conversion then if Is_Scalar_Type (A_Typ) then Apply_Scalar_Range_Check @@ -6163,9 +6159,7 @@ package body Sem_Res is Resolve_Actuals (N, Nam); Generate_Reference (Nam, Entry_Name); - if Ekind (Nam) = E_Entry - or else Ekind (Nam) = E_Entry_Family - then + if Ekind_In (Nam, E_Entry, E_Entry_Family) then Check_Potentially_Blocking_Operation (N); end if; @@ -8559,9 +8553,7 @@ package body Sem_Res is -- Handle subtypes - if Ekind (Opnd) = E_Protected_Subtype - or else Ekind (Opnd) = E_Task_Subtype - then + if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then Opnd := Etype (Opnd); end if; @@ -8954,19 +8946,20 @@ package body Sem_Res is Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); - Set_Scalar_Range (Index_Subtype, Drange); + -- Take a new copy of Drange (where bounds have been rewritten to + -- reference side-effect-vree names). Using a separate tree ensures + -- that further expansion (e.g while rewriting a slice assignment + -- into a FOR loop) does not attempt to remove side effects on the + -- bounds again (which would cause the bounds in the index subtype + -- definition to refer to temporaries before they are defined) (the + -- reason is that some names are considered side effect free here + -- for the subtype, but not in the context of a loop iteration + -- scheme). + + Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange)); Set_Etype (Index_Subtype, Index_Type); Set_Size_Info (Index_Subtype, Index_Type); Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); - - -- Now replace the discrete range in the slice with a reference to - -- its index subtype. This ensures that further expansion (e.g - -- while rewriting a slice assignment into a FOR loop) does not - -- attempt to remove side effects on the bounds again (which would - -- cause the bounds in the index subtype definition to refer to - -- temporaries before they are defined). - - Set_Discrete_Range (N, New_Copy_Tree (Drange)); end if; Slice_Subtype := Create_Itype (E_Array_Subtype, N); @@ -8979,15 +8972,26 @@ package body Sem_Res is Set_Etype (Slice_Subtype, Base_Type (Etype (N))); Set_Is_Constrained (Slice_Subtype, True); + Check_Compile_Time_Size (Slice_Subtype); + -- The Etype of the existing Slice node is reset to this slice subtype. -- Its bounds are obtained from its first index. Set_Etype (N, Slice_Subtype); - -- Always freeze subtype. This ensures that the slice subtype is - -- elaborated in the scope of the expression. + -- For packed slice subtypes, freeze immediately. Otherwise insert an + -- itype reference in the slice's actions so that the itype is frozen + -- at the proper place in the tree (i.e. at the point where actions + -- for the slice are analyzed). Note that this is different from + -- freezing the itype immediately, which might be premature (e.g. if + -- the slice is within a transient scope). + + if Is_Packed (Slice_Subtype) and not In_Spec_Expression then + Freeze_Itype (Slice_Subtype, N); - Freeze_Itype (Slice_Subtype, N); + else + Ensure_Defined (Typ => Slice_Subtype, N => N); + end if; end Set_Slice_Subtype; -------------------------------- @@ -9732,7 +9736,6 @@ package body Sem_Res is elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type and then not Is_Local_Anonymous_Access (Opnd_Type) then - -- When the operand is a selected access discriminant the check -- needs to be made against the level of the object denoted by -- the prefix of the selected name (Object_Access_Level handles diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index d35326e..d999cc2 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -362,7 +362,6 @@ package body Sem_Type is -- performed, given that the operator was visible in the generic. if Ekind (E) = E_Operator then - if Present (Opnd_Type) then Vis_Type := Opnd_Type; else @@ -803,8 +802,8 @@ package body Sem_Type is then return True; - -- The context may be class wide, and a class-wide type is - -- compatible with any member of the class. + -- The context may be class wide, and a class-wide type is compatible + -- with any member of the class. elsif Is_Class_Wide_Type (T1) and then Is_Ancestor (Root_Type (T1), T2) @@ -997,9 +996,7 @@ package body Sem_Type is -- imposed by context. elsif Ekind (T2) = E_Access_Attribute_Type - and then (Ekind (BT1) = E_General_Access_Type - or else - Ekind (BT1) = E_Access_Type) + and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type) and then Covers (Designated_Type (T1), Designated_Type (T2)) then -- If the target type is a RACW type while the source is an access @@ -1677,9 +1674,8 @@ package body Sem_Type is elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration and then Present (Access_Definition (Parent (N))) then - if Ekind (It1.Typ) = E_Anonymous_Access_Type - or else - Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type + if Ekind_In (It1.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) then if Ekind (It2.Typ) = Ekind (It1.Typ) then @@ -1691,9 +1687,8 @@ package body Sem_Type is return It1; end if; - elsif Ekind (It2.Typ) = E_Anonymous_Access_Type - or else - Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type + elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) then return It2; @@ -1880,8 +1875,8 @@ package body Sem_Type is if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type and then - List_Containing (Parent (Designated_Type (Etype (Opnd)))) - = List_Containing (Unit_Declaration_Node (User_Subp)) + List_Containing (Parent (Designated_Type (Etype (Opnd)))) + = List_Containing (Unit_Declaration_Node (User_Subp)) then if It2.Nam = Predef_Subp then return It1; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1cfa423..867ae0a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2817,9 +2817,7 @@ package body Sem_Util is -- Avoid cascaded messages with duplicate components in -- derived types. - if Ekind (E) = E_Component - or else Ekind (E) = E_Discriminant - then + if Ekind_In (E, E_Component, E_Discriminant) then return; end if; end if; @@ -2854,9 +2852,7 @@ package body Sem_Util is -- midst of inheriting components in a derived record definition. -- Preserve their Ekind and Etype. - if Ekind (Def_Id) = E_Discriminant - or else Ekind (Def_Id) = E_Component - then + if Ekind_In (Def_Id, E_Discriminant, E_Component) then null; -- If a type is already set, leave it alone (happens whey a type @@ -2876,8 +2872,7 @@ package body Sem_Util is -- Inherited discriminants and components in derived record types are -- immediately visible. Itypes are not. - if Ekind (Def_Id) = E_Discriminant - or else Ekind (Def_Id) = E_Component + if Ekind_In (Def_Id, E_Discriminant, E_Component) or else (No (Corresponding_Remote_Type (Def_Id)) and then not Is_Itype (Def_Id)) then @@ -4848,10 +4843,8 @@ package body Sem_Util is -- We are interested only in components and discriminants - if Ekind (Ent) = E_Component - or else - Ekind (Ent) = E_Discriminant - then + if Ekind_In (Ent, E_Component, E_Discriminant) then + -- Get default expression if any. If there is no declaration -- node, it means we have an internal entity. The parent and -- tag fields are examples of such entities. For these cases, @@ -6376,10 +6369,7 @@ package body Sem_Util is Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); begin - if Ekind (Ent) /= E_Variable - and then - Ekind (Ent) /= E_In_Out_Parameter - then + if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then return False; else return Present (Sub) and then Sub = Current_Subprogram; @@ -8658,9 +8648,7 @@ package body Sem_Util is -- If a record subtype is simply copied, the entity list will be -- shared. Thus cloned_Subtype must be set to indicate the sharing. - if Ekind (Old_Itype) = E_Record_Subtype - or else Ekind (Old_Itype) = E_Class_Wide_Subtype - then + if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then Set_Cloned_Subtype (New_Itype, Old_Itype); end if; @@ -10151,12 +10139,7 @@ package body Sem_Util is while R_Scope /= Standard_Standard loop exit when R_Scope = E_Scope; - if Ekind (R_Scope) /= E_Package - and then - Ekind (R_Scope) /= E_Block - and then - Ekind (R_Scope) /= E_Loop - then + if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then return False; else R_Scope := Scope (R_Scope); diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 3964781..0e00f51 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1027,9 +1027,8 @@ package body Sem_Warn is -- we exclude protected types, too complicated to worry about. if Ekind (E1) = E_Variable - or else - ((Ekind (E1) = E_Out_Parameter - or else Ekind (E1) = E_In_Out_Parameter) + or else + (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter) and then not Is_Protected_Type (Current_Scope)) then -- Case of an unassigned variable @@ -1345,7 +1344,7 @@ package body Sem_Warn is while Present (Comp) loop if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = - N_Component_Declaration + N_Component_Declaration and then No (Expression (Parent (Comp))) then Error_Msg_Node_2 := Comp; @@ -2883,9 +2882,7 @@ package body Sem_Warn is -- Reference to obsolescent component - elsif Ekind (E) = E_Component - or else Ekind (E) = E_Discriminant - then + elsif Ekind_In (E, E_Component, E_Discriminant) then Error_Msg_NE ("?reference to obsolescent component& declared#", N, E); |