diff options
Diffstat (limited to 'gcc/ada/sem_ch13.adb')
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 298 |
1 files changed, 1 insertions, 297 deletions
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 938e1d2..4724e0e 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -64,6 +64,7 @@ with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; +with Table; with Targparm; use Targparm; with Ttypes; use Ttypes; with Tbuild; use Tbuild; @@ -16224,303 +16225,6 @@ package body Sem_Ch13 is end loop; end Validate_Address_Clauses; - --------------------------- - -- Validate_Independence -- - --------------------------- - - procedure Validate_Independence is - SU : constant Uint := UI_From_Int (System_Storage_Unit); - N : Node_Id; - E : Entity_Id; - IC : Boolean; - Comp : Entity_Id; - Addr : Node_Id; - P : Node_Id; - - procedure Check_Array_Type (Atyp : Entity_Id); - -- Checks if the array type Atyp has independent components, and - -- if not, outputs an appropriate set of error messages. - - procedure No_Independence; - -- Output message that independence cannot be guaranteed - - function OK_Component (C : Entity_Id) return Boolean; - -- Checks one component to see if it is independently accessible, and - -- if so yields True, otherwise yields False if independent access - -- cannot be guaranteed. This is a conservative routine, it only - -- returns True if it knows for sure, it returns False if it knows - -- there is a problem, or it cannot be sure there is no problem. - - procedure Reason_Bad_Component (C : Entity_Id); - -- Outputs continuation message if a reason can be determined for - -- the component C being bad. - - ---------------------- - -- Check_Array_Type -- - ---------------------- - - procedure Check_Array_Type (Atyp : Entity_Id) is - Ctyp : constant Entity_Id := Component_Type (Atyp); - - begin - -- OK if no alignment clause, no pack, and no component size - - if not Has_Component_Size_Clause (Atyp) - and then not Has_Alignment_Clause (Atyp) - and then not Is_Packed (Atyp) - then - return; - end if; - - -- Case where component size is greater than or equal to the maximum - -- integer size and the alignment of the array is at least as large - -- as the alignment of the component. We are OK in this situation. - - if Known_Component_Size (Atyp) - and then Component_Size (Atyp) >= System_Max_Integer_Size - and then Known_Alignment (Atyp) - and then Known_Alignment (Ctyp) - and then Alignment (Atyp) >= Alignment (Ctyp) - then - return; - end if; - - -- Check actual component size - - if not Known_Component_Size (Atyp) - or else not Addressable (Component_Size (Atyp)) - or else Component_Size (Atyp) mod Esize (Ctyp) /= 0 - then - No_Independence; - - -- Bad component size, check reason - - if Has_Component_Size_Clause (Atyp) then - P := Get_Attribute_Definition_Clause - (Atyp, Attribute_Component_Size); - - if Present (P) then - Error_Msg_Sloc := Sloc (P); - Error_Msg_N ("\because of Component_Size clause#", N); - return; - end if; - end if; - - if Is_Packed (Atyp) then - P := Get_Rep_Pragma (Atyp, Name_Pack); - - if Present (P) then - Error_Msg_Sloc := Sloc (P); - Error_Msg_N ("\because of pragma Pack#", N); - return; - end if; - end if; - - -- No reason found, just return - - return; - end if; - - -- Array type is OK independence-wise - - return; - end Check_Array_Type; - - --------------------- - -- No_Independence -- - --------------------- - - procedure No_Independence is - begin - if Pragma_Name (N) = Name_Independent then - Error_Msg_NE ("independence cannot be guaranteed for&", N, E); - else - Error_Msg_NE - ("independent components cannot be guaranteed for&", N, E); - end if; - end No_Independence; - - ------------------ - -- OK_Component -- - ------------------ - - function OK_Component (C : Entity_Id) return Boolean is - Rec : constant Entity_Id := Scope (C); - Ctyp : constant Entity_Id := Etype (C); - - begin - -- OK if no component clause, no Pack, and no alignment clause - - if No (Component_Clause (C)) - and then not Is_Packed (Rec) - and then not Has_Alignment_Clause (Rec) - then - return True; - end if; - - -- Here we look at the actual component layout. A component is - -- addressable if its size is a multiple of the Esize of the - -- component type, and its starting position in the record has - -- appropriate alignment, and the record itself has appropriate - -- alignment to guarantee the component alignment. - - -- Make sure sizes are static, always assume the worst for any - -- cases where we cannot check static values. - - if not (Known_Static_Esize (C) - and then - Known_Static_Esize (Ctyp)) - then - return False; - end if; - - -- Size of component must be addressable or greater than the maximum - -- integer size and a multiple of bytes. - - if not Addressable (Esize (C)) - and then Esize (C) < System_Max_Integer_Size - then - return False; - end if; - - -- Check size is proper multiple - - if Esize (C) mod Esize (Ctyp) /= 0 then - return False; - end if; - - -- Check alignment of component is OK - - if not Known_Component_Bit_Offset (C) - or else Component_Bit_Offset (C) < Uint_0 - or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0 - then - return False; - end if; - - -- Check alignment of record type is OK - - if not Known_Alignment (Rec) - or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 - then - return False; - end if; - - -- All tests passed, component is addressable - - return True; - end OK_Component; - - -------------------------- - -- Reason_Bad_Component -- - -------------------------- - - procedure Reason_Bad_Component (C : Entity_Id) is - Rec : constant Entity_Id := Scope (C); - Ctyp : constant Entity_Id := Etype (C); - - begin - -- If component clause present assume that's the problem - - if Present (Component_Clause (C)) then - Error_Msg_Sloc := Sloc (Component_Clause (C)); - Error_Msg_N ("\because of Component_Clause#", N); - return; - end if; - - -- If pragma Pack clause present, assume that's the problem - - if Is_Packed (Rec) then - P := Get_Rep_Pragma (Rec, Name_Pack); - - if Present (P) then - Error_Msg_Sloc := Sloc (P); - Error_Msg_N ("\because of pragma Pack#", N); - return; - end if; - end if; - - -- See if record has bad alignment clause - - if Has_Alignment_Clause (Rec) - and then Known_Alignment (Rec) - and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 - then - P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment); - - if Present (P) then - Error_Msg_Sloc := Sloc (P); - Error_Msg_N ("\because of Alignment clause#", N); - end if; - end if; - - -- Couldn't find a reason, so return without a message - - return; - end Reason_Bad_Component; - - -- Start of processing for Validate_Independence - - begin - for J in Independence_Checks.First .. Independence_Checks.Last loop - N := Independence_Checks.Table (J).N; - E := Independence_Checks.Table (J).E; - IC := Pragma_Name (N) = Name_Independent_Components; - - -- Deal with component case - - if Ekind (E) in E_Component | E_Discriminant then - if not OK_Component (E) then - No_Independence; - Reason_Bad_Component (E); - goto Continue; - end if; - end if; - - -- Deal with record with Independent_Components - - if IC and then Is_Record_Type (E) then - Comp := First_Component_Or_Discriminant (E); - while Present (Comp) loop - if not OK_Component (Comp) then - No_Independence; - Reason_Bad_Component (Comp); - goto Continue; - end if; - - Next_Component_Or_Discriminant (Comp); - end loop; - end if; - - -- Deal with address clause case - - if Is_Object (E) then - Addr := Address_Clause (E); - - if Present (Addr) then - No_Independence; - Error_Msg_Sloc := Sloc (Addr); - Error_Msg_N ("\because of Address clause#", N); - goto Continue; - end if; - end if; - - -- Deal with independent components for array type - - if IC and then Is_Array_Type (E) then - Check_Array_Type (E); - end if; - - -- Deal with independent components for array object - - if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then - Check_Array_Type (Etype (E)); - end if; - - <<Continue>> null; - end loop; - end Validate_Independence; - ------------------------------ -- Validate_Iterable_Aspect -- ------------------------------ |