X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch13.adb;h=6a4d514958cb7755c39cf994f34b334a1aff3fce;hp=2030b3020a35d085b1f2211ea85f19727ad0ec4e;hb=7717ea00902734bd90371e34af23d0b73287f875;hpb=80d4fec446bcdba9588f2a861b2ddd449fb48292 diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2030b3020a3..6a4d514958c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -27,30 +26,38 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; +with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; -with Table; with Targparm; use Targparm; with Ttypes; use Ttypes; with Tbuild; use Tbuild; with Urealp; use Urealp; -with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; +with GNAT.Heap_Sort_G; package body Sem_Ch13 is @@ -63,14 +70,10 @@ package body Sem_Ch13 is procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id); -- This routine is called after setting the Esize of type entity Typ. - -- The purpose is to deal with the situation where an aligment has been + -- The purpose is to deal with the situation where an alignment has been -- 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 hav 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 @@ -82,27 +85,19 @@ package body Sem_Ch13 is -- Attributes that do not specify a representation characteristic are -- operational attributes. - function Address_Aliased_Entity (N : Node_Id) return Entity_Id; - -- If expression N is of the form E'Address, return E. - - procedure Mark_Aliased_Address_As_Volatile (N : Node_Id); - -- This is used for processing of an address representation clause. If - -- the expression N is of the form of K'Address, then the entity that - -- is associated with K is marked as volatile. - - procedure New_Stream_Function + procedure New_Stream_Subprogram (N : Node_Id; Ent : Entity_Id; Subp : Entity_Id; Nam : TSS_Name_Type); - -- Create a function renaming of a given stream attribute to the - -- designated subprogram and then in the tagged case, provide this as - -- a primitive operation, or in the non-tagged case make an appropriate - -- TSS entry. Used for Input. This is more properly an expansion activity - -- than just semantics, but the presence of user-defined stream functions - -- for limited types is a legality check, which is why this takes place - -- here rather than in exp_ch13, where it was previously. Nam indicates - -- the name of the TSS function to be generated. + -- Create a subprogram renaming of a given stream attribute to the + -- designated subprogram and then in the tagged case, provide this as a + -- primitive operation, or in the non-tagged case make an appropriate TSS + -- entry. This is more properly an expansion activity than just semantics, + -- but the presence of user-defined stream functions for limited types is a + -- legality check, which is why this takes place here rather than in + -- exp_ch13, where it was previously. Nam indicates the name of the TSS + -- function to be generated. -- -- To avoid elaboration anomalies with freeze nodes, for untagged types -- we generate both a subprogram declaration and a subprogram renaming @@ -110,17 +105,15 @@ package body Sem_Ch13 is -- renaming_as_body. For tagged types, the specification is one of the -- primitive specs. - procedure New_Stream_Procedure - (N : Node_Id; - Ent : Entity_Id; - Subp : Entity_Id; - Nam : TSS_Name_Type; - Out_P : Boolean := False); - -- Create a procedure renaming of a given stream attribute to the - -- designated subprogram and then in the tagged case, provide this as - -- a primitive operation, or in the non-tagged case make an appropriate - -- TSS entry. Used for Read, Output, Write. Nam indicates the name of - -- the TSS procedure to be generated. + procedure Set_Biased + (E : Entity_Id; + N : Node_Id; + Msg : String; + Biased : Boolean := True); + -- If Biased is True, sets Has_Biased_Representation flag for E, and + -- outputs a warning message at node N if Warn_On_Biased_Representation is + -- is True. This warning inserts the string Msg to describe the construct + -- causing biasing. ---------------------------------------------- -- Table for Validate_Unchecked_Conversions -- @@ -131,12 +124,16 @@ package body Sem_Ch13 is -- call to Validate_Unchecked_Conversions does the actual error -- checking and posting of warnings. The reason for this delayed -- processing is to take advantage of back-annotations of size and - -- alignment values peformed by the back end. + -- alignment values performed by the back end. + + -- Note: the reason we store a Source_Ptr value instead of a Node_Id + -- is that by the time Validate_Unchecked_Conversions is called, Sprint + -- will already have modified all Sloc values if the -gnatD option is set. type UC_Entry is record - Enode : Node_Id; -- node used for posting warnings - Source : Entity_Id; -- source type for unchecked conversion - Target : Entity_Id; -- target type for unchecked conversion + Eloc : Source_Ptr; -- node used for posting warnings + Source : Entity_Id; -- source type for unchecked conversion + Target : Entity_Id; -- target type for unchecked conversion end record; package Unchecked_Conversions is new Table.Table ( @@ -147,33 +144,460 @@ package body Sem_Ch13 is Table_Increment => 200, Table_Name => "Unchecked_Conversions"); - ---------------------------- - -- Address_Aliased_Entity -- - ---------------------------- + ---------------------------------------- + -- Table for Validate_Address_Clauses -- + ---------------------------------------- + + -- If an address clause has the form + + -- for X'Address use Expr + + -- where Expr is of the form Y'Address or recursively is a reference + -- to a constant of either of these forms, and X and Y are entities of + -- objects, then if Y has a smaller alignment than X, that merits a + -- warning about possible bad alignment. The following table collects + -- address clauses of this kind. We put these in a table so that they + -- can be checked after the back end has completed annotation of the + -- alignments of objects, since we can catch more cases that way. + + type Address_Clause_Check_Record is record + N : Node_Id; + -- The address clause + + X : Entity_Id; + -- The entity of the object overlaying Y + + Y : Entity_Id; + -- The entity of the object being overlaid + + Off : Boolean; + -- Whether the address is offseted within Y + end record; + + package Address_Clause_Checks is new Table.Table ( + Table_Component_Type => Address_Clause_Check_Record, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 20, + Table_Increment => 200, + Table_Name => "Address_Clause_Checks"); + + ----------------------------------------- + -- Adjust_Record_For_Reverse_Bit_Order -- + ----------------------------------------- + + procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is + Comp : Node_Id; + CC : Node_Id; - function Address_Aliased_Entity (N : Node_Id) return Entity_Id is begin - if Nkind (N) = N_Attribute_Reference - and then Attribute_Name (N) = Name_Address - then + -- Processing depends on version of Ada + + -- 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 Ada_Version < Ada_2005 then + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); + + -- If component clause is present, then deal with the non-default + -- bit order case for Ada 95 mode. + + -- We only do this processing for the base type, and in fact that + -- is important, since otherwise if there are record subtypes, we + -- could reverse the bits once for each subtype, which is wrong. + + 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); + + 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 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; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- 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. Same approach is still + -- valid in later versions including Ada 2012. + + else declare - Nam : Node_Id := Prefix (N); + Max_Machine_Scalar_Size : constant Uint := + UI_From_Int + (Standard_Long_Long_Integer_Size); + -- We use this as the maximum machine scalar size + + Num_CC : Natural; + SSU : constant Uint := UI_From_Int (System_Storage_Unit); + begin - while False - or else Nkind (Nam) = N_Selected_Component - or else Nkind (Nam) = N_Indexed_Component - loop - Nam := Prefix (Nam); + -- 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); + + if Present (CC) then + declare + Fbit : constant Uint := + Static_Integer (First_Bit (CC)); + + 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; + + -- Case where size is not greater than max machine + -- scalar. For now, we just count these. + + else + Num_CC := Num_CC + 1; + end if; + end; + end if; + + Next_Component_Or_Discriminant (Comp); end loop; - if Is_Entity_Name (Nam) then - return Entity (Nam); - 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. + + 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. + + function CP_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure CP_Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); + + Start : Natural; + Stop : Natural; + -- Start and stop positions in the component list of the set of + -- components with the same starting position (that constitute + -- components in a single machine scalar). + + MaxL : Uint; + -- Maximum last bit value of any component in this set + + 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 + -- Collect the component clauses + + 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; + + 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 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 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 if; - - return Empty; - end Address_Aliased_Entity; + end Adjust_Record_For_Reverse_Bit_Order; -------------------------------------- -- Alignment_Check_For_Esize_Change -- @@ -202,19 +626,35 @@ package body Sem_Ch13 is -- definition clause that is the preferred approach in Ada 95. procedure Analyze_At_Clause (N : Node_Id) is + CS : constant Boolean := Comes_From_Source (N); + begin + -- This is an obsolescent feature + + Check_Restriction (No_Obsolescent_Features, N); + if Warn_On_Obsolescent_Feature then Error_Msg_N - ("at clause is an obsolescent feature ('R'M 'J.7(2))?", N); + ("at clause is an obsolescent feature (RM J.7(2))?", N); Error_Msg_N - ("|use address attribute definition clause instead?", N); + ("\use address attribute definition clause instead?", N); end if; + -- Rewrite as address clause + Rewrite (N, Make_Attribute_Definition_Clause (Sloc (N), Name => Identifier (N), Chars => Name_Address, Expression => Expression (N))); + + -- We preserve Comes_From_Source, since logically the clause still + -- comes from the source program even though it is changed in form. + + Set_Comes_From_Source (N, CS); + + -- Analyze rewritten clause + Analyze_Attribute_Definition_Clause (N); end Analyze_At_Clause; @@ -240,7 +680,196 @@ package body Sem_Ch13 is -- disallow Storage_Size for derived task types, but that is also -- clearly unintentional. + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type); + -- Common processing for 'Read, 'Write, 'Input and 'Output attribute + -- definition clauses. + + ----------------------------------- + -- Analyze_Stream_TSS_Definition -- + ----------------------------------- + + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is + Subp : Entity_Id := Empty; + I : Interp_Index; + It : Interp; + Pnam : Entity_Id; + + Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read); + + function Has_Good_Profile (Subp : Entity_Id) return Boolean; + -- Return true if the entity is a subprogram with an appropriate + -- profile for the attribute being defined. + + ---------------------- + -- Has_Good_Profile -- + ---------------------- + + function Has_Good_Profile (Subp : Entity_Id) return Boolean is + F : Entity_Id; + Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input); + Expected_Ekind : constant array (Boolean) of Entity_Kind := + (False => E_Procedure, True => E_Function); + Typ : Entity_Id; + + begin + if Ekind (Subp) /= Expected_Ekind (Is_Function) then + return False; + end if; + + F := First_Formal (Subp); + + if No (F) + or else Ekind (Etype (F)) /= E_Anonymous_Access_Type + or else Designated_Type (Etype (F)) /= + Class_Wide_Type (RTE (RE_Root_Stream_Type)) + then + return False; + end if; + + if not Is_Function then + Next_Formal (F); + + declare + Expected_Mode : constant array (Boolean) of Entity_Kind := + (False => E_In_Parameter, + True => E_Out_Parameter); + begin + if Parameter_Mode (F) /= Expected_Mode (Is_Read) then + return False; + end if; + end; + + Typ := Etype (F); + + else + Typ := Etype (Subp); + end if; + + return Base_Type (Typ) = Base_Type (Ent) + and then No (Next_Formal (F)); + end Has_Good_Profile; + + -- Start of processing for Analyze_Stream_TSS_Definition + + begin + FOnly := True; + + if not Is_Type (U_Ent) then + Error_Msg_N ("local name must be a subtype", Nam); + return; + end if; + + Pnam := TSS (Base_Type (U_Ent), TSS_Nam); + + -- If Pnam is present, it can be either inherited from an ancestor + -- type (in which case it is legal to redefine it for this type), or + -- be a previous definition of the attribute for the same type (in + -- which case it is illegal). + + -- In the first case, it will have been analyzed already, and we + -- can check that its profile does not match the expected profile + -- for a stream attribute of U_Ent. In the second case, either Pnam + -- has been analyzed (and has the expected profile), or it has not + -- been analyzed yet (case of a type that has not been frozen yet + -- and for which the stream attribute has been set using Set_TSS). + + if Present (Pnam) + and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam)) + then + Error_Msg_Sloc := Sloc (Pnam); + Error_Msg_Name_1 := Attr; + Error_Msg_N ("% attribute already defined #", Nam); + return; + end if; + + Analyze (Expr); + + if Is_Entity_Name (Expr) then + if not Is_Overloaded (Expr) then + if Has_Good_Profile (Entity (Expr)) then + Subp := Entity (Expr); + end if; + + else + Get_First_Interp (Expr, I, It); + while Present (It.Nam) loop + if Has_Good_Profile (It.Nam) then + Subp := It.Nam; + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end if; + + if Present (Subp) then + if Is_Abstract_Subprogram (Subp) then + Error_Msg_N ("stream subprogram must not be abstract", Expr); + return; + end if; + + Set_Entity (Expr, Subp); + Set_Etype (Expr, Etype (Subp)); + + New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam); + + else + Error_Msg_Name_1 := Attr; + Error_Msg_N ("incorrect expression for% attribute", Expr); + end if; + end Analyze_Stream_TSS_Definition; + + -- Start of processing for Analyze_Attribute_Definition_Clause + begin + -- Process Ignore_Rep_Clauses option + + if Ignore_Rep_Clauses then + case Id is + + -- The following should be ignored. They do not affect legality + -- and may be target dependent. The basic idea of -gnatI is to + -- ignore any rep clauses that may be target dependent but do not + -- affect legality (except possibly to be rejected because they + -- are incompatible with the compilation target). + + when Attribute_Alignment | + Attribute_Bit_Order | + Attribute_Component_Size | + Attribute_Machine_Radix | + Attribute_Object_Size | + Attribute_Size | + Attribute_Small | + Attribute_Stream_Size | + Attribute_Value_Size => + + Rewrite (N, Make_Null_Statement (Sloc (N))); + return; + + -- The following should not be ignored, because in the first place + -- they are reasonably portable, and should not cause problems in + -- compiling code from another target, and also they do affect + -- legality, e.g. failing to provide a stream attribute for a + -- type may make a program illegal. + + when Attribute_External_Tag | + Attribute_Input | + Attribute_Output | + Attribute_Read | + Attribute_Storage_Pool | + Attribute_Storage_Size | + Attribute_Write => + null; + + -- Other cases are errors ("attribute& cannot be set with + -- definition clause"), which will be caught below. + + when others => + null; + end case; + end if; + Analyze (Nam); Ent := Entity (Nam); @@ -248,26 +877,26 @@ package body Sem_Ch13 is return; end if; - -- Rep clause applies to full view of incomplete type or private type - -- if we have one (if not, this is a premature use of the type). - -- However, certain semantic checks need to be done on the specified - -- entity (i.e. the private view), so we save it in Ent. + -- Rep clause applies to full view of incomplete type or private type if + -- we have one (if not, this is a premature use of the type). However, + -- certain semantic checks need to be done on the specified entity (i.e. + -- the private view), so we save it in Ent. if Is_Private_Type (Ent) and then Is_Derived_Type (Ent) and then not Is_Tagged_Type (Ent) and then No (Full_View (Ent)) then - -- If this is a private type whose completion is a derivation - -- from another private type, there is no full view, and the - -- attribute belongs to the type itself, not its underlying parent. + -- If this is a private type whose completion is a derivation from + -- another private type, there is no full view, and the attribute + -- belongs to the type itself, not its underlying parent. U_Ent := Ent; elsif Ekind (Ent) = E_Incomplete_Type then - -- The attribute applies to the full view, set the entity - -- of the attribute definition accordingly. + -- The attribute applies to the full view, set the entity of the + -- attribute definition accordingly. Ent := Underlying_Type (Ent); U_Ent := Ent; @@ -297,7 +926,6 @@ package body Sem_Ch13 is then Error_Msg_N ("cannot specify attribute for subtype", Nam); return; - end if; -- Switch on particular attribute @@ -311,8 +939,36 @@ package body Sem_Ch13 is -- Address attribute definition clause when Attribute_Address => Address : begin + + -- A little error check, catch for X'Address use X'Address; + + if Nkind (Nam) = N_Identifier + and then Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Address + and then Nkind (Prefix (Expr)) = N_Identifier + and then Chars (Nam) = Chars (Prefix (Expr)) + then + Error_Msg_NE + ("address for & is self-referencing", Prefix (Expr), Ent); + return; + end if; + + -- Not that special case, carry on with analysis of expression + Analyze_And_Resolve (Expr, RTE (RE_Address)); + -- Even when ignoring rep clauses we need to indicate that the + -- entity has an address clause and thus it is legal to declare + -- it imported. + + if Ignore_Rep_Clauses then + if Ekind_In (U_Ent, E_Variable, E_Constant) then + Record_Rep_Item (U_Ent, N); + end if; + + return; + end if; + if Present (Address_Clause (U_Ent)) then Error_Msg_N ("address already given for &", Nam); @@ -324,11 +980,12 @@ package body Sem_Ch13 is ("address clause cannot be given " & "for overloaded subprogram", Nam); + return; end if; - -- For subprograms, all address clauses are permitted, - -- and we mark the subprogram as having a deferred freeze - -- so that Gigi will not elaborate it too soon. + -- For subprograms, all address clauses are permitted, and we + -- mark the subprogram as having a deferred freeze so that Gigi + -- will not elaborate it too soon. -- Above needs more comments, what is too soon about??? @@ -340,12 +997,15 @@ package body Sem_Ch13 is if Nkind (Parent (N)) = N_Task_Body then Error_Msg_N ("entry address must be specified in task spec", Nam); + return; end if; -- For entries, we require a constant address Check_Constant_Address_Clause (Expr, U_Ent); + -- Special checks for task types + if Is_Task_Type (Scope (U_Ent)) and then Comes_From_Source (Scope (U_Ent)) then @@ -355,18 +1015,24 @@ package body Sem_Ch13 is ("\?only one task can be declared of this type", N); end if; + -- Entry address clauses are obsolescent + + Check_Restriction (No_Obsolescent_Features, N); + if Warn_On_Obsolescent_Feature then Error_Msg_N ("attaching interrupt to task entry is an " & - "obsolescent feature ('R'M 'J.7.1)?", N); + "obsolescent feature (RM J.7.1)?", N); Error_Msg_N - ("|use interrupt procedure instead?", N); + ("\use interrupt procedure instead?", N); end if; - -- Case of an address clause for a controlled object: - -- erroneous execution. + -- Case of an address clause for a controlled object which we + -- consider to be erroneous. - elsif Is_Controlled (Etype (U_Ent)) then + elsif Is_Controlled (Etype (U_Ent)) + or else Has_Controlled_Component (Etype (U_Ent)) + then Error_Msg_NE ("?controlled object& must not be overlaid", Nam, U_Ent); Error_Msg_N @@ -374,6 +1040,7 @@ package body Sem_Ch13 is Insert_Action (Declaration_Node (U_Ent), Make_Raise_Program_Error (Loc, Reason => PE_Overlaid_Controlled_Object)); + return; -- Case of address clause for a (non-controlled) object @@ -383,40 +1050,48 @@ package body Sem_Ch13 is Ekind (U_Ent) = E_Constant then declare - Expr : constant Node_Id := Expression (N); - Aent : constant Entity_Id := Address_Aliased_Entity (Expr); + Expr : constant Node_Id := Expression (N); + O_Ent : Entity_Id; + Off : Boolean; begin - -- Exported variables cannot have an address clause, - -- because this cancels the effect of the pragma Export + -- Exported variables cannot have an address clause, because + -- this cancels the effect of the pragma Export. if Is_Exported (U_Ent) then Error_Msg_N ("cannot export object with address clause", Nam); + return; + end if; + + Find_Overlaid_Entity (N, O_Ent, Off); -- Overlaying controlled objects is erroneous - elsif Present (Aent) - and then Is_Controlled (Etype (Aent)) + if Present (O_Ent) + and then (Has_Controlled_Component (Etype (O_Ent)) + or else Is_Controlled (Etype (O_Ent))) then Error_Msg_N - ("?controlled object must not be overlaid", Expr); + ("?cannot overlay with controlled object", Expr); Error_Msg_N ("\?Program_Error will be raised at run time", Expr); Insert_Action (Declaration_Node (U_Ent), Make_Raise_Program_Error (Loc, Reason => PE_Overlaid_Controlled_Object)); + return; - elsif Present (Aent) + elsif Present (O_Ent) and then Ekind (U_Ent) = E_Constant - and then Ekind (Aent) /= E_Constant + and then not Is_Constant_Object (O_Ent) then Error_Msg_N ("constant overlays a variable?", Expr); elsif Present (Renamed_Object (U_Ent)) then Error_Msg_N ("address clause not allowed" - & " for a renaming declaration ('R'M 13.1(6))", Nam); + & " for a renaming declaration (RM 13.1(6))", Nam); + return; -- Imported variables can have an address clause, but then -- the import is pretty meaningless except to suppress @@ -431,43 +1106,20 @@ package body Sem_Ch13 is -- We mark a possible modification of a variable with an -- address clause, since it is likely aliasing is occurring. - Note_Possible_Modification (Nam); - - -- Here we are checking for explicit overlap of one - -- variable by another, and if we find this, then we - -- mark the overlapped variable as also being aliased. - - -- First case is where we have an explicit - - -- for J'Address use K'Address; - - -- In this case, we mark K as volatile - - Mark_Aliased_Address_As_Volatile (Expr); + Note_Possible_Modification (Nam, Sure => False); - -- Second case is where we have a constant whose - -- definition is of the form of an adress as in: + -- Here we are checking for explicit overlap of one variable + -- by another, and if we find this then mark the overlapped + -- variable as also being volatile to prevent unwanted + -- optimizations. This is a significant pessimization so + -- avoid it when there is an offset, i.e. when the object + -- is composite; they cannot be optimized easily anyway. - -- A : constant Address := K'Address; - -- ... - -- for B'Address use A; - - -- In this case we also mark K as volatile - - if Is_Entity_Name (Expr) then - declare - Ent : constant Entity_Id := Entity (Expr); - Decl : constant Node_Id := Declaration_Node (Ent); - - begin - if Ekind (Ent) = E_Constant - and then Nkind (Decl) = N_Object_Declaration - and then Present (Expression (Decl)) - then - Mark_Aliased_Address_As_Volatile - (Expression (Decl)); - end if; - end; + if Present (O_Ent) + and then Is_Object (O_Ent) + and then not Off + then + Set_Treat_As_Volatile (O_Ent); end if; -- Legality checks on the address clause for initialized @@ -477,6 +1129,21 @@ package body Sem_Ch13 is Set_Has_Delayed_Freeze (U_Ent); + -- If an initialization call has been generated for this + -- object, it needs to be deferred to after the freeze node + -- we have just now added, otherwise GIGI will see a + -- reference to the variable (as actual to the IP call) + -- before its definition. + + declare + Init_Call : constant Node_Id := Find_Init_Call (U_Ent, N); + begin + if Present (Init_Call) then + Remove (Init_Call); + Append_Freeze_Action (U_Ent, Init_Call); + end if; + end; + if Is_Exported (U_Ent) then Error_Msg_N ("& cannot be exported if an address clause is given", @@ -487,16 +1154,60 @@ package body Sem_Ch13 is Nam); end if; - -- Entity has delayed freeze, so we will generate - -- an alignment check at the freeze point. + -- Entity has delayed freeze, so we will generate an + -- alignment check at the freeze point unless suppressed. - Set_Check_Address_Alignment - (N, not Range_Checks_Suppressed (U_Ent)); + if not Range_Checks_Suppressed (U_Ent) + and then not Alignment_Checks_Suppressed (U_Ent) + then + Set_Check_Address_Alignment (N); + end if; -- Kill the size check code, since we are not allocating -- the variable, it is somewhere else. Kill_Size_Check_Code (U_Ent); + + -- If the address clause is of the form: + + -- for Y'Address use X'Address + + -- or + + -- Const : constant Address := X'Address; + -- ... + -- for Y'Address use Const; + + -- then we make an entry in the table for checking the size + -- and alignment of the overlaying variable. We defer this + -- check till after code generation to take full advantage + -- of the annotation done by the back end. This entry is + -- only made if the address clause comes from source. + -- If the entity has a generic type, the check will be + -- performed in the instance if the actual type justifies + -- it, and we do not insert the clause in the table to + -- prevent spurious warnings. + + if Address_Clause_Overlay_Warnings + and then Comes_From_Source (N) + and then Present (O_Ent) + and then Is_Object (O_Ent) + then + if not Is_Generic_Type (Etype (U_Ent)) then + Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); + end if; + + -- If variable overlays a constant view, and we are + -- warning on overlays, then mark the variable as + -- overlaying a constant (we will give warnings later + -- if this variable is assigned). + + if Is_Constant_Object (O_Ent) + and then Ekind (U_Ent) = E_Variable + then + Set_Overlays_Constant (U_Ent); + end if; + end if; end; -- Not a valid entity for an address clause @@ -512,7 +1223,7 @@ package body Sem_Ch13 is -- Alignment attribute definition clause - when Attribute_Alignment => Alignment_Block : declare + when Attribute_Alignment => Alignment : declare Align : constant Uint := Get_Alignment_Value (Expr); begin @@ -531,8 +1242,17 @@ package body Sem_Ch13 is elsif Align /= No_Uint then Set_Has_Alignment_Clause (U_Ent); Set_Alignment (U_Ent, Align); + + -- For an array type, U_Ent is the first subtype. In that case, + -- also set the alignment of the anonymous base type so that + -- other subtypes (such as the itypes for aggregates of the + -- type) also receive the expected alignment. + + if Is_Array_Type (U_Ent) then + Set_Alignment (Base_Type (U_Ent), Align); + end if; end if; - end Alignment_Block; + end Alignment; --------------- -- Bit_Order -- @@ -572,6 +1292,7 @@ package body Sem_Ch13 is when Attribute_Component_Size => Component_Size_Case : declare Csize : constant Uint := Static_Integer (Expr); + Ctyp : Entity_Id; Btype : Entity_Id; Biased : Boolean; New_Ctyp : Entity_Id; @@ -584,58 +1305,79 @@ package body Sem_Ch13 is end if; Btype := Base_Type (U_Ent); + Ctyp := Component_Type (Btype); if Has_Component_Size_Clause (Btype) then Error_Msg_N - ("component size clase for& previously given", Nam); + ("component size clause for& previously given", Nam); - elsif Csize /= No_Uint then - Check_Size (Expr, Component_Type (Btype), Csize, Biased); + elsif Rep_Item_Too_Early (Btype, N) then + null; - if Has_Aliased_Components (Btype) - and then Csize < 32 - and then Csize /= 8 - and then Csize /= 16 - then - Error_Msg_N - ("component size incorrect for aliased components", N); - return; - end if; + elsif Csize /= No_Uint then + Check_Size (Expr, Ctyp, Csize, Biased); -- For the biased case, build a declaration for a subtype -- that will be used to represent the biased subtype that -- reflects the biased representation of components. We need -- this subtype to get proper conversions on referencing - -- elements of the array. + -- elements of the array. Note that component size clauses + -- are ignored in VM mode. + + if VM_Target = No_VM then + if Biased then + New_Ctyp := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (U_Ent), 'C', 0, 'T')); + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => New_Ctyp, + Subtype_Indication => + New_Occurrence_Of (Component_Type (Btype), Loc)); + + Set_Parent (Decl, N); + Analyze (Decl, Suppress => All_Checks); + + Set_Has_Delayed_Freeze (New_Ctyp, False); + Set_Esize (New_Ctyp, Csize); + Set_RM_Size (New_Ctyp, Csize); + Init_Alignment (New_Ctyp); + Set_Is_Itype (New_Ctyp, True); + Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); + + Set_Component_Type (Btype, New_Ctyp); + Set_Biased (New_Ctyp, N, "component size clause"); + end if; + + Set_Component_Size (Btype, Csize); - if Biased then - New_Ctyp := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (U_Ent), 'C', 0, 'T')); + -- For VM case, we ignore component size clauses - Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => New_Ctyp, - Subtype_Indication => - New_Occurrence_Of (Component_Type (Btype), Loc)); + else + -- Give a warning unless we are in GNAT mode, in which case + -- the warning is suppressed since it is not useful. - Set_Parent (Decl, N); - Analyze (Decl, Suppress => All_Checks); + if not GNAT_Mode then + Error_Msg_N + ("?component size ignored in this configuration", N); + end if; + end if; - Set_Has_Delayed_Freeze (New_Ctyp, False); - Set_Esize (New_Ctyp, Csize); - Set_RM_Size (New_Ctyp, Csize); - Init_Alignment (New_Ctyp); - Set_Has_Biased_Representation (New_Ctyp, True); - Set_Is_Itype (New_Ctyp, True); - Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); + -- Deal with warning on overridden size - Set_Component_Type (Btype, New_Ctyp); + if Warn_On_Overridden_Size + and then Has_Size_Clause (Ctyp) + and then RM_Size (Ctyp) /= Csize + then + Error_Msg_NE + ("?component size overrides size clause for&", + N, Ctyp); end if; - Set_Component_Size (Btype, Csize); Set_Has_Component_Size_Clause (Btype, True); - Set_Has_Non_Standard_Rep (Btype, True); + Set_Has_Non_Standard_Rep (Btype, True); end if; end Component_Size_Case; @@ -656,101 +1398,31 @@ package body Sem_Ch13 is ("static string required for tag name!", Nam); end if; - Set_Has_External_Tag_Rep_Clause (U_Ent); + if VM_Target = No_VM then + Set_Has_External_Tag_Rep_Clause (U_Ent); + else + Error_Msg_Name_1 := Attr; + Error_Msg_N + ("% attribute unsupported in this configuration", Nam); + end if; + + if not Is_Library_Level_Entity (U_Ent) then + Error_Msg_NE + ("?non-unique external tag supplied for &", N, U_Ent); + Error_Msg_N + ("?\same external tag applies to all subprogram calls", N); + Error_Msg_N + ("?\corresponding internal tag cannot be obtained", N); + end if; end External_Tag; ----------- -- Input -- ----------- - when Attribute_Input => Input : declare - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; - - function Has_Good_Profile (Subp : Entity_Id) return Boolean; - -- Return true if the entity is a function with an appropriate - -- profile for the Input attribute. - - ---------------------- - -- Has_Good_Profile -- - ---------------------- - - function Has_Good_Profile (Subp : Entity_Id) return Boolean is - F : Entity_Id; - Ok : Boolean := False; - - begin - if Ekind (Subp) = E_Function then - F := First_Formal (Subp); - - if Present (F) and then No (Next_Formal (F)) then - if Ekind (Etype (F)) = E_Anonymous_Access_Type - and then - Designated_Type (Etype (F)) = - Class_Wide_Type (RTE (RE_Root_Stream_Type)) - then - Ok := Base_Type (Etype (Subp)) = Base_Type (Ent); - end if; - end if; - end if; - - return Ok; - end Has_Good_Profile; - - -- Start of processing for Input attribute definition - - begin - FOnly := True; - - if not Is_Type (U_Ent) then - Error_Msg_N ("local name must be a subtype", Nam); - return; - - else - Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Input); - - if Present (Pnam) - and then Base_Type (Etype (Pnam)) = Base_Type (U_Ent) - then - Error_Msg_Sloc := Sloc (Pnam); - Error_Msg_N ("input attribute already defined #", Nam); - return; - end if; - end if; - - Analyze (Expr); - - if Is_Entity_Name (Expr) then - if not Is_Overloaded (Expr) then - if Has_Good_Profile (Entity (Expr)) then - Subp := Entity (Expr); - end if; - - else - Get_First_Interp (Expr, I, It); - - while Present (It.Nam) loop - if Has_Good_Profile (It.Nam) then - Subp := It.Nam; - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - end if; - - if Present (Subp) then - Set_Entity (Expr, Subp); - Set_Etype (Expr, Etype (Subp)); - New_Stream_Function (N, U_Ent, Subp, TSS_Stream_Input); - else - Error_Msg_N ("incorrect expression for input attribute", Expr); - return; - end if; - end Input; + when Attribute_Input => + Analyze_Stream_TSS_Definition (TSS_Stream_Input); + Set_Has_Specified_Stream_Input (Ent); ------------------- -- Machine_Radix -- @@ -790,8 +1462,10 @@ package body Sem_Ch13 is -- Object_Size attribute definition clause when Attribute_Object_Size => Object_Size : declare - Size : constant Uint := Static_Integer (Expr); + Size : constant Uint := Static_Integer (Expr); + Biased : Boolean; + pragma Warnings (Off, Biased); begin if not Is_Type (U_Ent) then @@ -826,198 +1500,17 @@ package body Sem_Ch13 is -- Output -- ------------ - when Attribute_Output => Output : declare - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; - - function Has_Good_Profile (Subp : Entity_Id) return Boolean; - -- Return true if the entity is a procedure with an - -- appropriate profile for the output attribute. - - ---------------------- - -- Has_Good_Profile -- - ---------------------- - - function Has_Good_Profile (Subp : Entity_Id) return Boolean is - F : Entity_Id; - Ok : Boolean := False; - - begin - if Ekind (Subp) = E_Procedure then - F := First_Formal (Subp); - - if Present (F) then - if Ekind (Etype (F)) = E_Anonymous_Access_Type - and then - Designated_Type (Etype (F)) = - Class_Wide_Type (RTE (RE_Root_Stream_Type)) - then - Next_Formal (F); - Ok := Present (F) - and then Parameter_Mode (F) = E_In_Parameter - and then Base_Type (Etype (F)) = Base_Type (Ent) - and then No (Next_Formal (F)); - end if; - end if; - end if; - - return Ok; - end Has_Good_Profile; - - -- Start of processing for Output attribute definition - - begin - FOnly := True; - - if not Is_Type (U_Ent) then - Error_Msg_N ("local name must be a subtype", Nam); - return; - - else - Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Output); - - if Present (Pnam) - and then - Base_Type (Etype (Next_Formal (First_Formal (Pnam)))) - = Base_Type (U_Ent) - then - Error_Msg_Sloc := Sloc (Pnam); - Error_Msg_N ("output attribute already defined #", Nam); - return; - end if; - end if; - - Analyze (Expr); - - if Is_Entity_Name (Expr) then - if not Is_Overloaded (Expr) then - if Has_Good_Profile (Entity (Expr)) then - Subp := Entity (Expr); - end if; - - else - Get_First_Interp (Expr, I, It); - - while Present (It.Nam) loop - if Has_Good_Profile (It.Nam) then - Subp := It.Nam; - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - end if; - - if Present (Subp) then - Set_Entity (Expr, Subp); - Set_Etype (Expr, Etype (Subp)); - New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Output); - else - Error_Msg_N ("incorrect expression for output attribute", Expr); - return; - end if; - end Output; + when Attribute_Output => + Analyze_Stream_TSS_Definition (TSS_Stream_Output); + Set_Has_Specified_Stream_Output (Ent); ---------- -- Read -- ---------- - when Attribute_Read => Read : declare - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; - - function Has_Good_Profile (Subp : Entity_Id) return Boolean; - -- Return true if the entity is a procedure with an appropriate - -- profile for the Read attribute. - - ---------------------- - -- Has_Good_Profile -- - ---------------------- - - function Has_Good_Profile (Subp : Entity_Id) return Boolean is - F : Entity_Id; - Ok : Boolean := False; - - begin - if Ekind (Subp) = E_Procedure then - F := First_Formal (Subp); - - if Present (F) then - if Ekind (Etype (F)) = E_Anonymous_Access_Type - and then - Designated_Type (Etype (F)) = - Class_Wide_Type (RTE (RE_Root_Stream_Type)) - then - Next_Formal (F); - Ok := Present (F) - and then Parameter_Mode (F) = E_Out_Parameter - and then Base_Type (Etype (F)) = Base_Type (Ent) - and then No (Next_Formal (F)); - end if; - end if; - end if; - - return Ok; - end Has_Good_Profile; - - -- Start of processing for Read attribute definition - - begin - FOnly := True; - - if not Is_Type (U_Ent) then - Error_Msg_N ("local name must be a subtype", Nam); - return; - - else - Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Read); - - if Present (Pnam) - and then Base_Type (Etype (Next_Formal (First_Formal (Pnam)))) - = Base_Type (U_Ent) - then - Error_Msg_Sloc := Sloc (Pnam); - Error_Msg_N ("read attribute already defined #", Nam); - return; - end if; - end if; - - Analyze (Expr); - - if Is_Entity_Name (Expr) then - if not Is_Overloaded (Expr) then - if Has_Good_Profile (Entity (Expr)) then - Subp := Entity (Expr); - end if; - - else - Get_First_Interp (Expr, I, It); - - while Present (It.Nam) loop - if Has_Good_Profile (It.Nam) then - Subp := It.Nam; - exit; - end if; - - Get_Next_Interp (I, It); - end loop; - end if; - end if; - - if Present (Subp) then - Set_Entity (Expr, Subp); - Set_Etype (Expr, Etype (Subp)); - New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Read, True); - else - Error_Msg_N ("incorrect expression for read attribute", Expr); - return; - end if; - end Read; + when Attribute_Read => + Analyze_Stream_TSS_Definition (TSS_Stream_Read); + Set_Has_Specified_Stream_Read (Ent); ---------- -- Size -- @@ -1049,24 +1542,35 @@ package body Sem_Ch13 is ("size cannot be given for unconstrained array", Nam); elsif Size /= No_Uint then + + if VM_Target /= No_VM and then not GNAT_Mode then + + -- Size clause is not handled properly on VM targets. + -- Display a warning unless we are in GNAT mode, in which + -- case this is useless. + + Error_Msg_N + ("?size clauses are ignored in this configuration", N); + end if; + if Is_Type (U_Ent) then Etyp := U_Ent; else Etyp := Etype (U_Ent); end if; - -- Check size, note that Gigi is in charge of checking - -- that the size of an array or record type is OK. Also - -- we do not check the size in the ordinary fixed-point - -- case, since it is too early to do so (there may be a - -- subsequent small clause that affects the size). We can - -- check the size if a small clause has already been given. + -- Check size, note that Gigi is in charge of checking that the + -- size of an array or record type is OK. Also we do not check + -- the size in the ordinary fixed-point case, since it is too + -- early to do so (there may be subsequent small clause that + -- affects the size). We can check the size if a small clause + -- has already been given. if not Is_Ordinary_Fixed_Point_Type (U_Ent) or else Has_Small_Clause (U_Ent) then Check_Size (Expr, Etyp, Size, Biased); - Set_Has_Biased_Representation (U_Ent, Biased); + Set_Biased (U_Ent, N, "size clause", Biased); end if; -- For types set RM_Size and Esize if possible @@ -1074,9 +1578,9 @@ package body Sem_Ch13 is if Is_Type (U_Ent) then Set_RM_Size (U_Ent, Size); - -- For scalar types, increase Object_Size to power of 2, - -- but not less than a storage unit in any case (i.e., - -- normally this means it will be byte addressable). + -- For scalar types, increase Object_Size to power of 2, but + -- not less than a storage unit in any case (i.e., normally + -- this means it will be byte addressable). if Is_Scalar_Type (U_Ent) then if Size <= System_Storage_Unit then @@ -1110,8 +1614,11 @@ package body Sem_Ch13 is and then Size /= System_Storage_Unit * 8 then + Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); + Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8; Error_Msg_N - ("size for primitive object must be power of 2", N); + ("size for primitive object must be a power of 2" + & " in the range ^-^", N); end if; end if; @@ -1174,105 +1681,72 @@ package body Sem_Ch13 is end Small; ------------------ - -- Storage_Size -- + -- Storage_Pool -- ------------------ - -- Storage_Size attribute definition clause + -- Storage_Pool attribute definition clause - when Attribute_Storage_Size => Storage_Size : declare - Btype : constant Entity_Id := Base_Type (U_Ent); - Sprag : Node_Id; + when Attribute_Storage_Pool => Storage_Pool : declare + Pool : Entity_Id; + T : Entity_Id; begin - if Is_Task_Type (U_Ent) then - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("storage size clause for task is an " & - "obsolescent feature ('R'M 'J.9)?", N); - Error_Msg_N - ("|use Storage_Size pragma instead?", N); - end if; - - FOnly := True; - end if; + if Ekind (U_Ent) = E_Access_Subprogram_Type then + Error_Msg_N + ("storage pool cannot be given for access-to-subprogram type", + Nam); + return; - if not Is_Access_Type (U_Ent) - and then Ekind (U_Ent) /= E_Task_Type + elsif not + Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) then - Error_Msg_N ("storage size cannot be given for &", Nam); + Error_Msg_N + ("storage pool can only be given for access types", Nam); + return; - elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then + elsif Is_Derived_Type (U_Ent) then Error_Msg_N - ("storage size cannot be given for a derived access type", + ("storage pool cannot be given for a derived access type", Nam); - elsif Has_Storage_Size_Clause (Btype) then + elsif Has_Storage_Size_Clause (U_Ent) then Error_Msg_N ("storage size already given for &", Nam); + return; - else - Analyze_And_Resolve (Expr, Any_Integer); + elsif Present (Associated_Storage_Pool (U_Ent)) then + Error_Msg_N ("storage pool already given for &", Nam); + return; + end if; - if Is_Access_Type (U_Ent) then + Analyze_And_Resolve + (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); - if Present (Associated_Storage_Pool (U_Ent)) then - Error_Msg_N ("storage pool already given for &", Nam); - return; - end if; + if not Denotes_Variable (Expr) then + Error_Msg_N ("storage pool must be a variable", Expr); + return; + end if; - if Compile_Time_Known_Value (Expr) - and then Expr_Value (Expr) = 0 - then - Set_No_Pool_Assigned (Btype); - end if; + if Nkind (Expr) = N_Type_Conversion then + T := Etype (Expression (Expr)); + else + T := Etype (Expr); + end if; - else -- Is_Task_Type (U_Ent) - Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size); - - if Present (Sprag) then - Error_Msg_Sloc := Sloc (Sprag); - Error_Msg_N - ("Storage_Size already specified#", Nam); - return; - end if; - end if; - - Set_Has_Storage_Size_Clause (Btype); - end if; - end Storage_Size; - - ------------------ - -- Storage_Pool -- - ------------------ - - -- Storage_Pool attribute definition clause - - when Attribute_Storage_Pool => Storage_Pool : declare - Pool : Entity_Id; - - begin - if Ekind (U_Ent) /= E_Access_Type - and then Ekind (U_Ent) /= E_General_Access_Type - then - Error_Msg_N ( - "storage pool can only be given for access types", Nam); - return; - - elsif Is_Derived_Type (U_Ent) then - Error_Msg_N - ("storage pool cannot be given for a derived access type", - Nam); - - elsif Has_Storage_Size_Clause (U_Ent) then - Error_Msg_N ("storage size already given for &", Nam); - return; - - elsif Present (Associated_Storage_Pool (U_Ent)) then - Error_Msg_N ("storage pool already given for &", Nam); - return; - end if; - - Analyze_And_Resolve - (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + -- The Stack_Bounded_Pool is used internally for implementing + -- access types with a Storage_Size. Since it only work + -- properly when used on one specific type, we need to check + -- that it is not hijacked improperly: + -- type T is access Integer; + -- for T'Storage_Size use n; + -- type Q is access Float; + -- for Q'Storage_Size use T'Storage_Size; -- incorrect + + if RTE_Available (RE_Stack_Bounded_Pool) + and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool) + then + Error_Msg_N ("non-shareable internal Pool", Expr); + return; + end if; -- If the argument is a name that is not an entity name, then -- we construct a renaming operation to define an entity of @@ -1281,9 +1755,7 @@ package body Sem_Ch13 is if not Is_Entity_Name (Expr) and then Is_Object_Reference (Expr) then - Pool := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Pool := Make_Temporary (Loc, 'P', Expr); declare Rnode : constant Node_Id := @@ -1291,7 +1763,7 @@ package body Sem_Ch13 is Defining_Identifier => Pool, Subtype_Mark => New_Occurrence_Of (Etype (Expr), Loc), - Name => Expr); + Name => Expr); begin Insert_Before (N, Rnode); @@ -1318,33 +1790,14 @@ package body Sem_Ch13 is Pool := Entity (Expression (Renamed_Object (Pool))); end if; - if Present (Etype (Pool)) - and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool) - and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool) - then - Set_Associated_Storage_Pool (U_Ent, Pool); - else - Error_Msg_N ("Non sharable GNAT Pool", Expr); - end if; - - -- The pool may be specified as the Storage_Pool of some other - -- type. It is rewritten as a class_wide conversion of the - -- corresponding pool entity. + Set_Associated_Storage_Pool (U_Ent, Pool); elsif Nkind (Expr) = N_Type_Conversion and then Is_Entity_Name (Expression (Expr)) and then Nkind (Original_Node (Expr)) = N_Attribute_Reference then Pool := Entity (Expression (Expr)); - - if Present (Etype (Pool)) - and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool) - and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool) - then - Set_Associated_Storage_Pool (U_Ent, Pool); - else - Error_Msg_N ("Non sharable GNAT Pool", Expr); - end if; + Set_Associated_Storage_Pool (U_Ent, Pool); else Error_Msg_N ("incorrect reference to a Storage Pool", Expr); @@ -1352,142 +1805,165 @@ package body Sem_Ch13 is end if; end Storage_Pool; - ---------------- - -- Value_Size -- - ---------------- + ------------------ + -- Storage_Size -- + ------------------ - -- Value_Size attribute definition clause + -- Storage_Size attribute definition clause - when Attribute_Value_Size => Value_Size : declare - Size : constant Uint := Static_Integer (Expr); - Biased : Boolean; + when Attribute_Storage_Size => Storage_Size : declare + Btype : constant Entity_Id := Base_Type (U_Ent); + Sprag : Node_Id; begin - if not Is_Type (U_Ent) then - Error_Msg_N ("Value_Size cannot be given for &", Nam); - - elsif Present - (Get_Attribute_Definition_Clause - (U_Ent, Attribute_Value_Size)) - then - Error_Msg_N ("Value_Size already given for &", Nam); + if Is_Task_Type (U_Ent) then + Check_Restriction (No_Obsolescent_Features, N); - else - if Is_Elementary_Type (U_Ent) then - Check_Size (Expr, U_Ent, Size, Biased); - Set_Has_Biased_Representation (U_Ent, Biased); + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("storage size clause for task is an " & + "obsolescent feature (RM J.9)?", N); + Error_Msg_N ("\use Storage_Size pragma instead?", N); end if; - Set_RM_Size (U_Ent, Size); + FOnly := True; end if; - end Value_Size; - ----------- - -- Write -- - ----------- + if not Is_Access_Type (U_Ent) + and then Ekind (U_Ent) /= E_Task_Type + then + Error_Msg_N ("storage size cannot be given for &", Nam); + + elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then + Error_Msg_N + ("storage size cannot be given for a derived access type", + Nam); - -- Write attribute definition clause - -- check for class-wide case will be performed later + elsif Has_Storage_Size_Clause (Btype) then + Error_Msg_N ("storage size already given for &", Nam); - when Attribute_Write => Write : declare - Subp : Entity_Id := Empty; - I : Interp_Index; - It : Interp; - Pnam : Entity_Id; + else + Analyze_And_Resolve (Expr, Any_Integer); - function Has_Good_Profile (Subp : Entity_Id) return Boolean; - -- Return true if the entity is a procedure with an - -- appropriate profile for the write attribute. + if Is_Access_Type (U_Ent) then + if Present (Associated_Storage_Pool (U_Ent)) then + Error_Msg_N ("storage pool already given for &", Nam); + return; + end if; - ---------------------- - -- Has_Good_Profile -- - ---------------------- + if Is_OK_Static_Expression (Expr) + and then Expr_Value (Expr) = 0 + then + Set_No_Pool_Assigned (Btype); + end if; - function Has_Good_Profile (Subp : Entity_Id) return Boolean is - F : Entity_Id; - Ok : Boolean := False; + else -- Is_Task_Type (U_Ent) + Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size); - begin - if Ekind (Subp) = E_Procedure then - F := First_Formal (Subp); - - if Present (F) then - if Ekind (Etype (F)) = E_Anonymous_Access_Type - and then - Designated_Type (Etype (F)) = - Class_Wide_Type (RTE (RE_Root_Stream_Type)) - then - Next_Formal (F); - Ok := Present (F) - and then Parameter_Mode (F) = E_In_Parameter - and then Base_Type (Etype (F)) = Base_Type (Ent) - and then No (Next_Formal (F)); - end if; + if Present (Sprag) then + Error_Msg_Sloc := Sloc (Sprag); + Error_Msg_N + ("Storage_Size already specified#", Nam); + return; end if; end if; - return Ok; - end Has_Good_Profile; + Set_Has_Storage_Size_Clause (Btype); + end if; + end Storage_Size; - -- Start of processing for Write attribute definition + ----------------- + -- Stream_Size -- + ----------------- - begin - FOnly := True; + when Attribute_Stream_Size => Stream_Size : declare + Size : constant Uint := Static_Integer (Expr); - if not Is_Type (U_Ent) then - Error_Msg_N ("local name must be a subtype", Nam); - return; + begin + if Ada_Version <= Ada_95 then + Check_Restriction (No_Implementation_Attributes, N); end if; - Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Write); + if Has_Stream_Size_Clause (U_Ent) then + Error_Msg_N ("Stream_Size already given for &", Nam); - if Present (Pnam) - and then Base_Type (Etype (Next_Formal (First_Formal (Pnam)))) - = Base_Type (U_Ent) - then - Error_Msg_Sloc := Sloc (Pnam); - Error_Msg_N ("write attribute already defined #", Nam); - return; + elsif Is_Elementary_Type (U_Ent) then + if Size /= System_Storage_Unit + and then + Size /= System_Storage_Unit * 2 + and then + Size /= System_Storage_Unit * 4 + and then + Size /= System_Storage_Unit * 8 + then + Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); + Error_Msg_N + ("stream size for elementary type must be a" + & " power of 2 and at least ^", N); + + elsif RM_Size (U_Ent) > Size then + Error_Msg_Uint_1 := RM_Size (U_Ent); + Error_Msg_N + ("stream size for elementary type must be a" + & " power of 2 and at least ^", N); + end if; + + Set_Has_Stream_Size_Clause (U_Ent); + + else + Error_Msg_N ("Stream_Size cannot be given for &", Nam); end if; + end Stream_Size; - Analyze (Expr); + ---------------- + -- Value_Size -- + ---------------- - if Is_Entity_Name (Expr) then - if not Is_Overloaded (Expr) then - if Has_Good_Profile (Entity (Expr)) then - Subp := Entity (Expr); - end if; + -- Value_Size attribute definition clause - else - Get_First_Interp (Expr, I, It); + when Attribute_Value_Size => Value_Size : declare + Size : constant Uint := Static_Integer (Expr); + Biased : Boolean; - while Present (It.Nam) loop - if Has_Good_Profile (It.Nam) then - Subp := It.Nam; - exit; - end if; + begin + if not Is_Type (U_Ent) then + Error_Msg_N ("Value_Size cannot be given for &", Nam); - Get_Next_Interp (I, It); - end loop; - end if; - end if; + elsif Present + (Get_Attribute_Definition_Clause + (U_Ent, Attribute_Value_Size)) + then + Error_Msg_N ("Value_Size already given for &", Nam); + + elsif Is_Array_Type (U_Ent) + and then not Is_Constrained (U_Ent) + then + Error_Msg_N + ("Value_Size cannot be given for unconstrained array", Nam); - if Present (Subp) then - Set_Entity (Expr, Subp); - Set_Etype (Expr, Etype (Subp)); - New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Write); else - Error_Msg_N ("incorrect expression for write attribute", Expr); - return; + if Is_Elementary_Type (U_Ent) then + Check_Size (Expr, U_Ent, Size, Biased); + Set_Biased (U_Ent, N, "value size clause", Biased); + end if; + + Set_RM_Size (U_Ent, Size); end if; - end Write; + end Value_Size; + + ----------- + -- Write -- + ----------- + + when Attribute_Write => + Analyze_Stream_TSS_Definition (TSS_Stream_Write); + Set_Has_Specified_Stream_Write (Ent); -- All other attributes cannot be set when others => Error_Msg_N ("attribute& cannot be set with definition clause", N); - end case; -- The test for the type being frozen must be performed after @@ -1526,6 +2002,8 @@ package body Sem_Ch13 is return; end if; + Check_Code_Statement (N); + -- Make sure we appear in the handled statement sequence of a -- subprogram (RM 13.8(3)). @@ -1557,10 +2035,10 @@ package body Sem_Ch13 is while Present (Decl) loop DeclO := Original_Node (Decl); if Comes_From_Source (DeclO) - and then Nkind (DeclO) /= N_Pragma - and then Nkind (DeclO) /= N_Use_Package_Clause - and then Nkind (DeclO) /= N_Use_Type_Clause - and then Nkind (DeclO) /= N_Implicit_Label_Declaration + and not Nkind_In (DeclO, N_Pragma, + N_Use_Package_Clause, + N_Use_Type_Clause, + N_Implicit_Label_Declaration) then Error_Msg_N ("this declaration not allowed in machine code subprogram", @@ -1577,9 +2055,9 @@ package body Sem_Ch13 is while Present (Stmt) loop StmtO := Original_Node (Stmt); if Comes_From_Source (StmtO) - and then Nkind (StmtO) /= N_Pragma - and then Nkind (StmtO) /= N_Label - and then Nkind (StmtO) /= N_Code_Statement + and then not Nkind_In (StmtO, N_Pragma, + N_Label, + N_Code_Statement) then Error_Msg_N ("this statement is not allowed in machine code subprogram", @@ -1606,12 +2084,22 @@ package body Sem_Ch13 is Val : Uint; Err : Boolean := False; - Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); - Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); + Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); + Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); + -- Allowed range of universal integer (= allowed range of enum lit vals) + Min : Uint; Max : Uint; + -- Minimum and maximum values of entries + + Max_Node : Node_Id; + -- Pointer to node for literal providing max value begin + if Ignore_Rep_Clauses then + return; + end if; + -- First some basic error checks Find_Type (Ident); @@ -1657,14 +2145,20 @@ package body Sem_Ch13 is Error_Msg_N ("duplicate enumeration rep clause ignored", N); return; - -- Don't allow rep clause if root type is standard [wide_]character + -- Don't allow rep clause for standard [wide_[wide_]]character - elsif Root_Type (Enumtype) = Standard_Character - or else Root_Type (Enumtype) = Standard_Wide_Character - then + elsif Is_Standard_Character_Type (Enumtype) then Error_Msg_N ("enumeration rep clause not allowed for this type", N); return; + -- Check that the expression is a proper aggregate (no parentheses) + + elsif Paren_Count (Aggr) /= 0 then + Error_Msg + ("extra parentheses surrounding aggregate not allowed", + First_Sloc (Aggr)); + return; + -- All tests passed, so set rep clause in place else @@ -1677,10 +2171,6 @@ package body Sem_Ch13 is -- normal expansion activities, and a number of special semantic -- rules apply (including the component type being any integer type) - -- Badent signals that we found some incorrect entries processing - -- the list. The final checks for completeness and ordering are - -- skipped in this case. - Elit := First_Literal (Enumtype); -- First the positional entries if any @@ -1695,9 +2185,12 @@ package body Sem_Ch13 is Val := Static_Integer (Expr); + -- Err signals that we found some incorrect entries processing + -- the list. The final checks for completeness and ordering are + -- skipped in this case. + if Val = No_Uint then Err := True; - elsif Val < Lo or else Hi < Val then Error_Msg_N ("value outside permitted range", Expr); Err := True; @@ -1759,7 +2252,7 @@ package body Sem_Ch13 is Err := True; end if; - Set_Enumeration_Rep_Expr (Elit, Choice); + Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); Expr := Expression (Assoc); Val := Static_Integer (Expr); @@ -1805,15 +2298,16 @@ package body Sem_Ch13 is if Max /= No_Uint and then Val <= Max then Error_Msg_NE ("enumeration value for& not ordered!", - Enumeration_Rep_Expr (Elit), Elit); + Enumeration_Rep_Expr (Elit), Elit); end if; + Max_Node := Enumeration_Rep_Expr (Elit); Max := Val; end if; - -- If there is at least one literal whose representation - -- is not equal to the Pos value, then note that this - -- enumeration type has a non-standard representation. + -- If there is at least one literal whose representation is not + -- equal to the Pos value, then note that this enumeration type + -- has a non-standard representation. if Val /= Enumeration_Pos (Elit) then Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); @@ -1830,18 +2324,32 @@ package body Sem_Ch13 is begin if Has_Size_Clause (Enumtype) then - if Esize (Enumtype) >= Minsize then + + -- All OK, if size is OK now + + if RM_Size (Enumtype) >= Minsize then null; else + -- Try if we can get by with biasing + Minsize := UI_From_Int (Minimum_Size (Enumtype, Biased => True)); - if Esize (Enumtype) < Minsize then - Error_Msg_N ("previously given size is too small", N); + -- Error message if even biasing does not work + + if RM_Size (Enumtype) < Minsize then + Error_Msg_Uint_1 := RM_Size (Enumtype); + Error_Msg_Uint_2 := Max; + Error_Msg_N + ("previously given size (^) is too small " + & "for this value (^)", Max_Node); + + -- If biasing worked, indicate that we now have biased rep else - Set_Has_Biased_Representation (Enumtype); + Set_Biased + (Enumtype, Size_Clause (Enumtype), "size clause"); end if; end if; @@ -1872,71 +2380,174 @@ package body Sem_Ch13 is Analyze (Expression (N)); end Analyze_Free_Statement; - ------------------------------------------ - -- Analyze_Record_Representation_Clause -- - ------------------------------------------ - - 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; - Lbit : Uint; - Hbit : Uint := Uint_0; - Comp : Entity_Id; - Ocomp : 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. - - Overlap_Check_Required : Boolean; - -- Used to keep track of whether or not an overlap check is required + --------------------------- + -- Analyze_Freeze_Entity -- + --------------------------- - Ccount : Natural := 0; - -- Number of component clauses in record rep clause + procedure Analyze_Freeze_Entity (N : Node_Id) is + E : constant Entity_Id := Entity (N); begin - Find_Type (Ident); - Rectype := Entity (Ident); - - if Rectype = Any_Type - or else Rep_Item_Too_Early (Rectype, N) + -- Remember that we are processing a freezing entity. Required to + -- ensure correct decoration of internal entities associated with + -- interfaces (see New_Overloaded_Entity). + + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + + -- For tagged types covering interfaces add internal entities that link + -- the primitives of the interfaces with the primitives that cover them. + -- Note: These entities were originally generated only when generating + -- code because their main purpose was to provide support to initialize + -- the secondary dispatch tables. They are now generated also when + -- compiling with no code generation to provide ASIS the relationship + -- between interface primitives and tagged type primitives. They are + -- also used to locate primitives covering interfaces when processing + -- generics (see Derive_Subprograms). + + if Ada_Version >= Ada_05 + and then Ekind (E) = E_Record_Type + and then Is_Tagged_Type (E) + and then not Is_Interface (E) + and then Has_Interfaces (E) then - return; - else - Rectype := Underlying_Type (Rectype); + -- This would be a good common place to call the routine that checks + -- overriding of interface primitives (and thus factorize calls to + -- Check_Abstract_Overriding located at different contexts in the + -- compiler). However, this is not possible because it causes + -- spurious errors in case of late overriding. + + Add_Internal_Interface_Entities (E); end if; - -- First some basic error checks + -- Check CPP types - if not Is_Record_Type (Rectype) then - Error_Msg_NE - ("record type required, found}", Ident, First_Subtype (Rectype)); - return; + if Ekind (E) = E_Record_Type + and then Is_CPP_Class (E) + and then Is_Tagged_Type (E) + and then Tagged_Type_Expansion + and then Expander_Active + then + if CPP_Num_Prims (E) = 0 then - elsif Is_Unchecked_Union (Rectype) then - Error_Msg_N - ("record rep clause not allowed for Unchecked_Union", N); + -- If the CPP type has user defined components then it must import + -- primitives from C++. This is required because if the C++ class + -- has no primitives then the C++ compiler does not added the _tag + -- component to the type. - elsif Scope (Rectype) /= Current_Scope then - Error_Msg_N ("type must be declared in this scope", N); - return; + pragma Assert (Chars (First_Entity (E)) = Name_uTag); - elsif not Is_First_Subtype (Rectype) then - Error_Msg_N ("cannot give record rep clause for subtype", N); - return; + if First_Entity (E) /= Last_Entity (E) then + Error_Msg_N + ("?'C'P'P type must import at least one primitive from C++", + E); + end if; + end if; - elsif Has_Record_Rep_Clause (Rectype) then - Error_Msg_N ("duplicate record rep clause ignored", N); - return; + -- Check that all its primitives are abstract or imported from C++. + -- Check also availability of the C++ constructor. - elsif Rep_Item_Too_Late (Rectype, N) then + declare + Has_Constructors : constant Boolean := Has_CPP_Constructors (E); + Elmt : Elmt_Id; + Error_Reported : Boolean := False; + Prim : Node_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Comes_From_Source (Prim) then + if Is_Abstract_Subprogram (Prim) then + null; + + elsif not Is_Imported (Prim) + or else Convention (Prim) /= Convention_CPP + then + Error_Msg_N + ("?primitives of 'C'P'P types must be imported from C++" + & " or abstract", Prim); + + elsif not Has_Constructors + and then not Error_Reported + then + Error_Msg_Name_1 := Chars (E); + Error_Msg_N + ("?'C'P'P constructor required for type %", Prim); + Error_Reported := True; + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + end Analyze_Freeze_Entity; + + ------------------------------------------ + -- 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 + Ident : constant Node_Id := Identifier (N); + Biased : Boolean; + CC : Node_Id; + Comp : Entity_Id; + Fbit : Uint; + Hbit : Uint := Uint_0; + Lbit : Uint; + Ocomp : Entity_Id; + Posit : Uint; + Rectype : Entity_Id; + + CR_Pragma : Node_Id := Empty; + -- Points to N_Pragma node if Complete_Representation pragma present + + begin + if Ignore_Rep_Clauses then + return; + end if; + + Find_Type (Ident); + Rectype := Entity (Ident); + + if Rectype = Any_Type + or else Rep_Item_Too_Early (Rectype, N) + then + return; + else + Rectype := Underlying_Type (Rectype); + end if; + + -- First some basic error checks + + if not Is_Record_Type (Rectype) then + Error_Msg_NE + ("record type required, found}", Ident, First_Subtype (Rectype)); + return; + + elsif Scope (Rectype) /= Current_Scope then + Error_Msg_N ("type must be declared in this scope", N); + return; + + elsif not Is_First_Subtype (Rectype) then + Error_Msg_N ("cannot give record rep clause for subtype", N); + return; + + elsif Has_Record_Rep_Clause (Rectype) then + Error_Msg_N ("duplicate record rep clause ignored", N); + return; + + elsif Rep_Item_Too_Late (Rectype, N) then return; end if; @@ -1951,21 +2562,26 @@ package body Sem_Ch13 is pragma Warnings (Off, Mod_Val); begin + Check_Restriction (No_Obsolescent_Features, Mod_Clause (N)); + if Warn_On_Obsolescent_Feature then Error_Msg_N - ("mod clause is an obsolescent feature ('R'M 'J.8)?", N); + ("mod clause is an obsolescent feature (RM J.8)?", N); Error_Msg_N - ("|use alignment attribute definition clause instead?", N); + ("\use alignment attribute definition clause instead?", N); end if; if Present (P) then Analyze_List (P); end if; - -- In ASIS_Mode mode, expansion is disabled, but we must - -- convert the Mod clause into an alignment clause anyway, so - -- that the back-end can compute and back-annotate properly the - -- size and alignment of types that may include this record. + -- In ASIS_Mode mode, expansion is disabled, but we must convert + -- the Mod clause into an alignment clause anyway, so that the + -- back-end can compute and back-annotate properly the size and + -- alignment of types that may include this record. + + -- This seems dubious, this destroys the source tree in a manner + -- not detectable by ASIS ??? if Operating_Mode = Check_Semantics and then ASIS_Mode @@ -1985,26 +2601,23 @@ package body Sem_Ch13 is -- Get the alignment value to perform error checking Mod_Val := Get_Alignment_Value (Expression (M)); - end if; end; end if; - -- Clear any existing component clauses for the type (this happens - -- with derived types, where we are now overriding the original) - - Fent := First_Entity (Rectype); + -- For untagged types, clear any existing component clauses for the + -- type. If the type is derived, this is what allows us to override + -- a rep clause for the parent. For type extensions, the representation + -- of the inherited components is inherited, so we want to keep previous + -- component clauses for completeness. - Comp := Fent; - while Present (Comp) loop - if Ekind (Comp) = E_Component - or else Ekind (Comp) = E_Discriminant - then + if not Is_Tagged_Type (Rectype) then + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop Set_Component_Clause (Comp, Empty); - end if; - - Next_Entity (Comp); - end loop; + Next_Component_Or_Discriminant (Comp); + end loop; + end if; -- All done if no component clauses @@ -2014,62 +2627,30 @@ 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). - - 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 - -- If pragma, just analyze it + -- Pragma if Nkind (CC) = N_Pragma then Analyze (CC); + -- The only pragma of interest is Complete_Representation + + if Pragma_Name (CC) = Name_Complete_Representation then + CR_Pragma := CC; + end if; + -- 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)); @@ -2086,6 +2667,14 @@ package body Sem_Ch13 is Error_Msg_N ("first bit cannot be negative", First_Bit (CC)); + -- The Last_Bit specified in a component clause must not be + -- less than the First_Bit minus one (RM-13.5.1(10)). + + elsif Lbit < Fbit - 1 then + Error_Msg_N + ("last bit cannot be less than first bit minus one", + Last_Bit (CC)); + -- Values look OK, so find the corresponding record component -- Even though the syntax allows an attribute reference for -- implementation-defined components, GNAT does not allow the @@ -2121,23 +2710,73 @@ package body Sem_Ch13 is Error_Msg_N ("component clause is for non-existent field", CC); - elsif Present (Component_Clause (Comp)) then - Error_Msg_Sloc := Sloc (Component_Clause (Comp)); + -- Ada 2012 (AI05-0026): Any name that denotes a + -- discriminant of an object of an unchecked union type + -- shall not occur within a record_representation_clause. + + -- The general restriction of using record rep clauses on + -- Unchecked_Union types has now been lifted. Since it is + -- possible to introduce a record rep clause which mentions + -- the discriminant of an Unchecked_Union in non-Ada 2012 + -- code, this check is applied to all versions of the + -- language. + + elsif Ekind (Comp) = E_Discriminant + and then Is_Unchecked_Union (Rectype) + then Error_Msg_N - ("component clause previously given#", CC); + ("cannot reference discriminant of Unchecked_Union", + Component_Name (CC)); - else - -- Update Fbit and Lbit to the actual bit number. + elsif Present (Component_Clause (Comp)) then - Fbit := Fbit + UI_From_Int (SSU) * Posit; - Lbit := Lbit + UI_From_Int (SSU) * Posit; + -- Diagnose duplicate rep clause, or check consistency + -- if this is an inherited component. In a double fault, + -- there may be a duplicate inconsistent clause for an + -- inherited component. + + if Scope (Original_Record_Component (Comp)) = Rectype + or else Parent (Component_Clause (Comp)) = N + then + Error_Msg_Sloc := Sloc (Component_Clause (Comp)); + Error_Msg_N ("component clause previously given#", CC); - if Fbit <= Max_Bit_So_Far then - Overlap_Check_Required := True; else - Max_Bit_So_Far := Lbit; + declare + Rep1 : constant Node_Id := Component_Clause (Comp); + begin + if Intval (Position (Rep1)) /= + Intval (Position (CC)) + or else Intval (First_Bit (Rep1)) /= + Intval (First_Bit (CC)) + or else Intval (Last_Bit (Rep1)) /= + Intval (Last_Bit (CC)) + then + Error_Msg_N ("component clause inconsistent " + & "with representation of ancestor", CC); + elsif Warn_On_Redundant_Constructs then + Error_Msg_N ("?redundant component clause " + & "for inherited component!", CC); + end if; + end; end if; + -- Normal case where this is the first component clause we + -- have seen for this entity, so set it up properly. + + else + -- Make reference for field in record rep clause and set + -- appropriate entity field in the field identifier. + + Generate_Reference + (Comp, Component_Name (CC), Set_Ref => False); + Set_Entity (Component_Name (CC), Comp); + + -- Update Fbit and Lbit to the actual bit number + + Fbit := Fbit + UI_From_Int (SSU) * Posit; + Lbit := Lbit + UI_From_Int (SSU) * Posit; + if Has_Size_Clause (Rectype) and then Esize (Rectype) <= Lbit then @@ -2151,15 +2790,13 @@ 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 + if Warn_On_Overridden_Size + and then Has_Size_Clause (Etype (Comp)) + and then RM_Size (Etype (Comp)) /= Esize (Comp) then Error_Msg_NE - ("component overlaps tag field of&", - CC, Rectype); + ("?component size overrides size clause for&", + Component_Name (CC), Etype (Comp)); end if; -- This information is also set in the corresponding @@ -2178,7 +2815,8 @@ package body Sem_Ch13 is Esize (Comp), Biased); - Set_Has_Biased_Representation (Comp, Biased); + Set_Biased + (Comp, First_Node (CC), "component clause", Biased); if Present (Ocomp) then Set_Component_Clause (Ocomp, CC); @@ -2190,6 +2828,10 @@ package body Sem_Ch13 is Set_Normalized_Position_Max (Ocomp, Normalized_Position (Ocomp)); + -- Note: we don't use Set_Biased here, because we + -- already gave a warning above if needed, and we + -- would get a duplicate for the same name here. + Set_Has_Biased_Representation (Ocomp, Has_Biased_Representation (Comp)); end if; @@ -2206,650 +2848,1170 @@ 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). + -- Check missing components if Complete_Representation pragma appeared - if Overlap_Check_Required then - Overlap_Check1 : declare + if Present (CR_Pragma) then + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + if No (Component_Clause (Comp)) then + Error_Msg_NE + ("missing component clause for &", CR_Pragma, Comp); + end if; - 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. + Next_Component_Or_Discriminant (Comp); + end loop; - 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. + -- If no Complete_Representation pragma, warn if missing components - OC_Count : Natural := 0; - -- Count of entries in OC_Fbit and OC_Lbit + elsif Warn_On_Unrepped_Components then + declare + Num_Repped_Components : Nat := 0; + Num_Unrepped_Components : Nat := 0; - function OC_Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort (See GNAT.Heap_Sort_A) + begin + -- First count number of repped and unrepped components - procedure OC_Move (From : Natural; To : Natural); - -- Move routine for Sort (see GNAT.Heap_Sort_A) + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + if Present (Component_Clause (Comp)) then + Num_Repped_Components := Num_Repped_Components + 1; + else + Num_Unrepped_Components := Num_Unrepped_Components + 1; + end if; - function OC_Lt (Op1, Op2 : Natural) return Boolean is - begin - return OC_Fbit (Op1) < OC_Fbit (Op2); - end OC_Lt; + Next_Component_Or_Discriminant (Comp); + end loop; - procedure OC_Move (From : Natural; To : Natural) is - begin - OC_Fbit (To) := OC_Fbit (From); - OC_Lbit (To) := OC_Lbit (From); - end OC_Move; + -- We are only interested in the case where there is at least one + -- unrepped component, and at least half the components have rep + -- clauses. We figure that if less than half have them, then the + -- partial rep clause is really intentional. If the component + -- type has no underlying type set at this point (as for a generic + -- formal type), we don't know enough to give a warning on the + -- component. - 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 + if Num_Unrepped_Components > 0 + and then Num_Unrepped_Components < Num_Repped_Components + then + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + if No (Component_Clause (Comp)) + 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)))) + and then not Has_Warnings_Off (Rectype) then - OC_Count := OC_Count + 1; - Posit := Posit * SSU; - OC_Fbit (OC_Count) := Fbit + Posit; - OC_Lbit (OC_Count) := Lbit + Posit; + Error_Msg_Sloc := Sloc (Comp); + Error_Msg_NE + ("?no component clause given for & declared #", + N, Comp); end if; - end if; - - Next (CC); - end loop; - Sort - (OC_Count, - OC_Move'Unrestricted_Access, - OC_Lt'Unrestricted_Access); - - 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; + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + end; end if; + end Analyze_Record_Representation_Clause; - -- 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 the same variant, or whether we have a definite problem + ----------------------------------- + -- Check_Constant_Address_Clause -- + ----------------------------------- - if Overlap_Check_Required then - Overlap_Check2 : declare - C1_Ent, C2_Ent : Entity_Id; - -- Entities of components being checked for overlap + procedure Check_Constant_Address_Clause + (Expr : Node_Id; + U_Ent : Entity_Id) + is + procedure Check_At_Constant_Address (Nod : Node_Id); + -- Checks that the given node N represents a name whose 'Address is + -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the + -- address value is the same at the point of declaration of U_Ent and at + -- the time of elaboration of the address clause. - Clist : Node_Id; - -- Component_List node whose Component_Items are being checked + procedure Check_Expr_Constants (Nod : Node_Id); + -- Checks that Nod meets the requirements for a constant address clause + -- in the sense of the enclosing procedure. - Citem : Node_Id; - -- Component declaration for component being checked + procedure Check_List_Constants (Lst : List_Id); + -- Check that all elements of list Lst meet the requirements for a + -- constant address clause in the sense of the enclosing procedure. - begin - C1_Ent := First_Entity (Base_Type (Rectype)); + ------------------------------- + -- Check_At_Constant_Address -- + ------------------------------- - -- 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. + procedure Check_At_Constant_Address (Nod : Node_Id) is + begin + if Is_Entity_Name (Nod) then + if Present (Address_Clause (Entity ((Nod)))) then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_NE + ("address for& cannot" & + " depend on another address clause! (RM 13.1(22))!", + Nod, U_Ent); - Main_Component_Loop : while Present (C1_Ent) loop - if Ekind (C1_Ent) /= E_Component - and then Ekind (C1_Ent) /= E_Discriminant - then - goto Continue_Main_Component_Loop; - end if; + elsif In_Same_Source_Unit (Entity (Nod), U_Ent) + and then Sloc (U_Ent) < Sloc (Entity (Nod)) + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_Node_2 := U_Ent; + Error_Msg_NE + ("\& must be defined before & (RM 13.1(22))!", + Nod, Entity (Nod)); + 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 ??? + elsif Nkind (Nod) = N_Selected_Component then + declare + T : constant Entity_Id := Etype (Prefix (Nod)); - if No (Declaration_Node (C1_Ent)) then - goto Continue_Main_Component_Loop; - end if; + begin + if (Is_Record_Type (T) + and then Has_Discriminants (T)) + or else + (Is_Access_Type (T) + and then Is_Record_Type (Designated_Type (T)) + and then Has_Discriminants (Designated_Type (T))) + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_N + ("\address cannot depend on component" & + " of discriminated record (RM 13.1(22))!", + Nod); + else + Check_At_Constant_Address (Prefix (Nod)); + end if; + end; - Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); + elsif Nkind (Nod) = N_Indexed_Component then + Check_At_Constant_Address (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); - -- Loop through component lists that need checking. Check the - -- current component list and all lists in variants above us. + else + Check_Expr_Constants (Nod); + end if; + end Check_At_Constant_Address; + + -------------------------- + -- Check_Expr_Constants -- + -------------------------- + + procedure Check_Expr_Constants (Nod : Node_Id) is + Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent); + Ent : Entity_Id := Empty; + + begin + if Nkind (Nod) in N_Has_Etype + and then Etype (Nod) = Any_Type + then + return; + end if; + + case Nkind (Nod) is + when N_Empty | N_Error => + return; + + when N_Identifier | N_Expanded_Name => + Ent := Entity (Nod); + + -- We need to look at the original node if it is different + -- from the node, since we may have rewritten things and + -- substituted an identifier representing the rewrite. + + if Original_Node (Nod) /= Nod then + Check_Expr_Constants (Original_Node (Nod)); + + -- If the node is an object declaration without initial + -- value, some code has been expanded, and the expression + -- is not constant, even if the constituents might be + -- acceptable, as in A'Address + offset. + + if Ekind (Ent) = E_Variable + and then + Nkind (Declaration_Node (Ent)) = N_Object_Declaration + and then + No (Expression (Declaration_Node (Ent))) + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + + -- If entity is constant, it may be the result of expanding + -- a check. We must verify that its declaration appears + -- before the object in question, else we also reject the + -- address clause. + + elsif Ekind (Ent) = E_Constant + and then In_Same_Source_Unit (Ent, U_Ent) + and then Sloc (Ent) > Loc_U_Ent + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + end if; + + return; + end if; + + -- Otherwise look at the identifier and see if it is OK + + if Ekind_In (Ent, E_Named_Integer, E_Named_Real) + or else Is_Type (Ent) + then + return; + + elsif + Ekind (Ent) = E_Constant + or else + Ekind (Ent) = E_In_Parameter + then + -- This is the case where we must have Ent defined before + -- U_Ent. Clearly if they are in different units this + -- requirement is met since the unit containing Ent is + -- already processed. + + if not In_Same_Source_Unit (Ent, U_Ent) then + return; + + -- Otherwise location of Ent must be before the location + -- of U_Ent, that's what prior defined means. + + elsif Sloc (Ent) < Loc_U_Ent then + return; + + else + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_Node_2 := U_Ent; + Error_Msg_NE + ("\& must be defined before & (RM 13.1(22))!", + Nod, Ent); + end if; + + elsif Nkind (Original_Node (Nod)) = N_Function_Call then + Check_Expr_Constants (Original_Node (Nod)); + + else + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + + if Comes_From_Source (Ent) then + Error_Msg_NE + ("\reference to variable& not allowed" + & " (RM 13.1(22))!", Nod, Ent); + else + Error_Msg_N + ("non-static expression not allowed" + & " (RM 13.1(22))!", Nod); + end if; + end if; + + when N_Integer_Literal => + + -- If this is a rewritten unchecked conversion, in a system + -- where Address is an integer type, always use the base type + -- for a literal value. This is user-friendly and prevents + -- order-of-elaboration issues with instances of unchecked + -- conversion. + + if Nkind (Original_Node (Nod)) = N_Function_Call then + Set_Etype (Nod, Base_Type (Etype (Nod))); + end if; + + when N_Real_Literal | + N_String_Literal | + N_Character_Literal => + return; + + when N_Range => + Check_Expr_Constants (Low_Bound (Nod)); + Check_Expr_Constants (High_Bound (Nod)); + + when N_Explicit_Dereference => + Check_Expr_Constants (Prefix (Nod)); + + when N_Indexed_Component => + Check_Expr_Constants (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); + + when N_Slice => + Check_Expr_Constants (Prefix (Nod)); + Check_Expr_Constants (Discrete_Range (Nod)); + + when N_Selected_Component => + Check_Expr_Constants (Prefix (Nod)); + + when N_Attribute_Reference => + if Attribute_Name (Nod) = Name_Address + or else + Attribute_Name (Nod) = Name_Access + or else + Attribute_Name (Nod) = Name_Unchecked_Access + or else + Attribute_Name (Nod) = Name_Unrestricted_Access + then + Check_At_Constant_Address (Prefix (Nod)); + + else + Check_Expr_Constants (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); + end if; + + when N_Aggregate => + Check_List_Constants (Component_Associations (Nod)); + Check_List_Constants (Expressions (Nod)); + + when N_Component_Association => + Check_Expr_Constants (Expression (Nod)); + + when N_Extension_Aggregate => + Check_Expr_Constants (Ancestor_Part (Nod)); + Check_List_Constants (Component_Associations (Nod)); + Check_List_Constants (Expressions (Nod)); + + when N_Null => + return; + + when N_Binary_Op | N_Short_Circuit | N_Membership_Test => + Check_Expr_Constants (Left_Opnd (Nod)); + Check_Expr_Constants (Right_Opnd (Nod)); + + when N_Unary_Op => + Check_Expr_Constants (Right_Opnd (Nod)); + + when N_Type_Conversion | + N_Qualified_Expression | + N_Allocator => + Check_Expr_Constants (Expression (Nod)); + + when N_Unchecked_Type_Conversion => + Check_Expr_Constants (Expression (Nod)); + + -- If this is a rewritten unchecked conversion, subtypes in + -- this node are those created within the instance. To avoid + -- order of elaboration issues, replace them with their base + -- types. Note that address clauses can cause order of + -- elaboration problems because they are elaborated by the + -- back-end at the point of definition, and may mention + -- entities declared in between (as long as everything is + -- static). It is user-friendly to allow unchecked conversions + -- in this context. + + if Nkind (Original_Node (Nod)) = N_Function_Call then + Set_Etype (Expression (Nod), + Base_Type (Etype (Expression (Nod)))); + Set_Etype (Nod, Base_Type (Etype (Nod))); + end if; + + when N_Function_Call => + if not Is_Pure (Entity (Name (Nod))) then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + + Error_Msg_NE + ("\function & is not pure (RM 13.1(22))!", + Nod, Entity (Name (Nod))); + + else + Check_List_Constants (Parameter_Associations (Nod)); + end if; + + when N_Parameter_Association => + Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); + + when others => + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_NE + ("\must be constant defined before& (RM 13.1(22))!", + Nod, U_Ent); + end case; + end Check_Expr_Constants; + + -------------------------- + -- Check_List_Constants -- + -------------------------- + + procedure Check_List_Constants (Lst : List_Id) is + Nod1 : Node_Id; + + begin + if Present (Lst) then + Nod1 := First (Lst); + while Present (Nod1) loop + Check_Expr_Constants (Nod1); + Next (Nod1); + end loop; + end if; + end Check_List_Constants; + + -- Start of processing for Check_Constant_Address_Clause + + begin + -- If rep_clauses are to be ignored, no need for legality checks. In + -- particular, no need to pester user about rep clauses that violate + -- the rule on constant addresses, given that these clauses will be + -- removed by Freeze before they reach the back end. + + if not Ignore_Rep_Clauses then + Check_Expr_Constants (Expr); + end if; + 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 + + Overlap_Detected : Boolean := False; + -- Set True if an overlap is detected + + 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)); + Overlap_Detected := True; + 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; + + -- We need a full overlap check if record positions non-monotonic + + if Fbit <= Max_Bit_So_Far then + Overlap_Check_Required := True; + end if; + + Max_Bit_So_Far := Lbit; + + -- 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)); - Component_List_Loop : loop + -- Check for overlap with tag field - -- If derived type definition, go to full declaration - -- If at outer level, check discriminants if there are any + 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); + Overlap_Detected := True; + end if; - if Nkind (Clist) = N_Derived_Type_Definition then - Clist := Parent (Clist); - end if; + if Hbit < Lbit then + Hbit := Lbit; + end if; + end if; - -- Outer level of record definition, check discriminants + -- Check parent overlap if component might overlap parent field - if Nkind (Clist) = N_Full_Type_Declaration - or else Nkind (Clist) = N_Private_Type_Declaration + 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 - if Has_Discriminants (Defining_Identifier (Clist)) then - C2_Ent := - First_Discriminant (Defining_Identifier (Clist)); + Check_Component_Overlap (Comp, Pcomp); + end if; - 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; + Next_Component_Or_Discriminant (Pcomp); + end loop; + end if; + end if; - -- Record extension case + Next (CC); + end loop; - elsif Nkind (Clist) = N_Derived_Type_Definition then - Clist := Empty; + -- 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. - -- Otherwise check one component list + -- We do not need this check if all specified ranges were monotonic, + -- as recorded by Overlap_Check_Required being False at this stage. - else - Citem := First (Component_Items (Clist)); + -- 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). - 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; + if Overlap_Check_Required then + Overlap_Check1 : declare - Next (Citem); - end loop; - end if; + 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. - -- 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. + 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. - if Nkind (Parent (Clist)) = N_Variant then - Clist := Parent (Parent (Parent (Clist))); + OC_Count : Natural := 0; + -- Count of entries in OC_Fbit and OC_Lbit - -- Check for possible discriminant part in record, this is - -- treated essentially as another level in the recursion. - -- For this case we have the parent of the component list - -- is the record definition, and its parent is the full - -- type declaration which contains the discriminant - -- specifications. + function OC_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort - elsif Nkind (Parent (Clist)) = N_Record_Definition then - Clist := Parent (Parent ((Clist))); + procedure OC_Move (From : Natural; To : Natural); + -- Move routine for Sort - -- If neither of these two cases, we are at the top of - -- the tree + package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); - else - exit Component_List_Loop; - end if; - end loop Component_List_Loop; + ----------- + -- OC_Lt -- + ----------- - <> - Next_Entity (C1_Ent); + function OC_Lt (Op1, Op2 : Natural) return Boolean is + begin + return OC_Fbit (Op1) < OC_Fbit (Op2); + end OC_Lt; - end loop Main_Component_Loop; - end Overlap_Check2; - end if; + ------------- + -- OC_Move -- + ------------- - -- 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. + procedure OC_Move (From : Natural; To : Natural) is + begin + OC_Fbit (To) := OC_Fbit (From); + OC_Lbit (To) := OC_Lbit (From); + end OC_Move; - -- 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. + -- Start of processing for Overlap_Check - -- 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 appopriate to round up the size - -- to some convenient boundary, based on alignment considerations etc). + begin + CC := First (Component_Clauses (N)); + while Present (CC) loop - if Unknown_RM_Size (Rectype) - and then Hbit + 1 <= 32 - then - -- Nothing to do if at least one component with no component clause + -- Exclude component clause already marked in error - Comp := First_Entity (Rectype); - while Present (Comp) loop - if Ekind (Comp) = E_Component - or else Ekind (Comp) = E_Discriminant - then - if No (Component_Clause (Comp)) then - return; + 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; - end if; - Next_Entity (Comp); - end loop; + Next (CC); + end loop; - -- If we fall out of loop, all components have component clauses - -- and so we can set the size to the maximum value. + Sorting.Sort (OC_Count); - Set_RM_Size (Rectype, Hbit + 1); + 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; - 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 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 Chars (C1_Ent) = Name_uTag - and then Chars (C2_Ent) = Name_uTag - then - return; - end if; + if Overlap_Check_Required then + Overlap_Check2 : declare + C1_Ent, C2_Ent : Entity_Id; + -- Entities of components being checked for overlap - -- Here we check if the two fields overlap + Clist : Node_Id; + -- Component_List node whose Component_Items are being checked - 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); + Citem : Node_Id; + -- Component declaration for component being checked 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; + C1_Ent := First_Entity (Base_Type (Rectype)); - ----------------------------------- - -- Check_Constant_Address_Clause -- - ----------------------------------- + -- 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. - procedure Check_Constant_Address_Clause - (Expr : Node_Id; - U_Ent : Entity_Id) - is - procedure Check_At_Constant_Address (Nod : Node_Id); - -- Checks that the given node N represents a name whose 'Address - -- is constant (in the same sense as OK_Constant_Address_Clause, - -- i.e. the address value is the same at the point of declaration - -- of U_Ent and at the time of elaboration of the address clause. + 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; - procedure Check_Expr_Constants (Nod : Node_Id); - -- Checks that Nod meets the requirements for a constant address - -- clause in the sense of the enclosing procedure. + -- Skip overlap check if entity has no declaration node. This + -- happens with discriminants in constrained derived types. + -- Possibly we are missing some checks as a result, but that + -- does not seem terribly serious. - procedure Check_List_Constants (Lst : List_Id); - -- Check that all elements of list Lst meet the requirements for a - -- constant address clause in the sense of the enclosing procedure. + if No (Declaration_Node (C1_Ent)) then + goto Continue_Main_Component_Loop; + end if; - ------------------------------- - -- Check_At_Constant_Address -- - ------------------------------- + Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); - procedure Check_At_Constant_Address (Nod : Node_Id) is - begin - if Is_Entity_Name (Nod) then - if Present (Address_Clause (Entity ((Nod)))) then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_NE - ("address for& cannot" & - " depend on another address clause! ('R'M 13.1(22))!", - Nod, U_Ent); + -- Loop through component lists that need checking. Check the + -- current component list and all lists in variants above us. - elsif In_Same_Source_Unit (Entity (Nod), U_Ent) - and then Sloc (U_Ent) < Sloc (Entity (Nod)) - then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_Name_1 := Chars (Entity (Nod)); - Error_Msg_Name_2 := Chars (U_Ent); - Error_Msg_N - ("\% must be defined before % ('R'M 13.1(22))!", - Nod); - end if; + Component_List_Loop : loop - elsif Nkind (Nod) = N_Selected_Component then - declare - T : constant Entity_Id := Etype (Prefix (Nod)); + -- If derived type definition, go to full declaration + -- If at outer level, check discriminants if there are any. - begin - if (Is_Record_Type (T) - and then Has_Discriminants (T)) - or else - (Is_Access_Type (T) - and then Is_Record_Type (Designated_Type (T)) - and then Has_Discriminants (Designated_Type (T))) - then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_N - ("\address cannot depend on component" & - " of discriminated record ('R'M 13.1(22))!", - Nod); - else - Check_At_Constant_Address (Prefix (Nod)); - end if; - end; + if Nkind (Clist) = N_Derived_Type_Definition then + Clist := Parent (Clist); + end if; - elsif Nkind (Nod) = N_Indexed_Component then - Check_At_Constant_Address (Prefix (Nod)); - Check_List_Constants (Expressions (Nod)); + -- Outer level of record definition, check discriminants - else - Check_Expr_Constants (Nod); - end if; - end Check_At_Constant_Address; + 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; - -------------------------- - -- Check_Expr_Constants -- - -------------------------- + -- Record extension case - procedure Check_Expr_Constants (Nod : Node_Id) is - Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent); - Ent : Entity_Id := Empty; + elsif Nkind (Clist) = N_Derived_Type_Definition then + Clist := Empty; - begin - if Nkind (Nod) in N_Has_Etype - and then Etype (Nod) = Any_Type - then - return; - end if; + -- Otherwise check one component list - case Nkind (Nod) is - when N_Empty | N_Error => - return; + 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; - when N_Identifier | N_Expanded_Name => - Ent := Entity (Nod); + Next (Citem); + end loop; + end if; - -- We need to look at the original node if it is different - -- from the node, since we may have rewritten things and - -- substituted an identifier representing the rewrite. + -- 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 Original_Node (Nod) /= Nod then - Check_Expr_Constants (Original_Node (Nod)); + if Nkind (Parent (Clist)) = N_Variant then + Clist := Parent (Parent (Parent (Clist))); - -- If the node is an object declaration without initial - -- value, some code has been expanded, and the expression - -- is not constant, even if the constituents might be - -- acceptable, as in A'Address + offset. + -- 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. - if Ekind (Ent) = E_Variable - and then Nkind (Declaration_Node (Ent)) - = N_Object_Declaration - and then - No (Expression (Declaration_Node (Ent))) - then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); + elsif Nkind (Parent (Clist)) = N_Record_Definition then + Clist := Parent (Parent ((Clist))); - -- If entity is constant, it may be the result of expanding - -- a check. We must verify that its declaration appears - -- before the object in question, else we also reject the - -- address clause. + -- If neither of these two cases, we are at the top of + -- the tree. - elsif Ekind (Ent) = E_Constant - and then In_Same_Source_Unit (Ent, U_Ent) - and then Sloc (Ent) > Loc_U_Ent - then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); + else + exit Component_List_Loop; end if; + end loop Component_List_Loop; - return; - end if; - - -- Otherwise look at the identifier and see if it is OK. + <> + Next_Entity (C1_Ent); - if Ekind (Ent) = E_Named_Integer - or else - Ekind (Ent) = E_Named_Real - or else - Is_Type (Ent) - then - return; + end loop Main_Component_Loop; + end Overlap_Check2; + end if; - elsif - Ekind (Ent) = E_Constant - or else - Ekind (Ent) = E_In_Parameter - then - -- This is the case where we must have Ent defined - -- before U_Ent. Clearly if they are in different - -- units this requirement is met since the unit - -- containing Ent is already processed. + -- The following circuit deals with warning on record holes (gaps). We + -- skip this check if overlap was detected, since it makes sense for the + -- programmer to fix this illegality before worrying about warnings. + + if not Overlap_Detected and Warn_On_Record_Holes then + Record_Hole_Check : declare + Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype)); + -- Full declaration of record type + + procedure Check_Component_List + (CL : Node_Id; + Sbit : Uint; + DS : List_Id); + -- Check component list CL for holes. The starting bit should be + -- Sbit. which is zero for the main record component list and set + -- appropriately for recursive calls for variants. DS is set to + -- a list of discriminant specifications to be included in the + -- consideration of components. It is No_List if none to consider. + + -------------------------- + -- Check_Component_List -- + -------------------------- + + procedure Check_Component_List + (CL : Node_Id; + Sbit : Uint; + DS : List_Id) + is + Compl : Integer; - if not In_Same_Source_Unit (Ent, U_Ent) then - return; + begin + Compl := Integer (List_Length (Component_Items (CL))); - -- Otherwise location of Ent must be before the - -- location of U_Ent, that's what prior defined means. + if DS /= No_List then + Compl := Compl + Integer (List_Length (DS)); + end if; - elsif Sloc (Ent) < Loc_U_Ent then - return; + declare + Comps : array (Natural range 0 .. Compl) of Entity_Id; + -- Gather components (zero entry is for sort routine) - else - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_Name_1 := Chars (Ent); - Error_Msg_Name_2 := Chars (U_Ent); - Error_Msg_N - ("\% must be defined before % ('R'M 13.1(22))!", - Nod); - end if; + Ncomps : Natural := 0; + -- Number of entries stored in Comps (starting at Comps (1)) - elsif Nkind (Original_Node (Nod)) = N_Function_Call then - Check_Expr_Constants (Original_Node (Nod)); + Citem : Node_Id; + -- One component item or discriminant specification - else - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); + Nbit : Uint; + -- Starting bit for next component - if Comes_From_Source (Ent) then - Error_Msg_Name_1 := Chars (Ent); - Error_Msg_N - ("\reference to variable% not allowed" - & " ('R'M 13.1(22))!", Nod); - else - Error_Msg_N - ("non-static expression not allowed" - & " ('R'M 13.1(22))!", Nod); - end if; - end if; + CEnt : Entity_Id; + -- Component entity - when N_Integer_Literal => + Variant : Node_Id; + -- One variant - -- If this is a rewritten unchecked conversion, in a system - -- where Address is an integer type, always use the base type - -- for a literal value. This is user-friendly and prevents - -- order-of-elaboration issues with instances of unchecked - -- conversion. + function Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort - if Nkind (Original_Node (Nod)) = N_Function_Call then - Set_Etype (Nod, Base_Type (Etype (Nod))); - end if; + procedure Move (From : Natural; To : Natural); + -- Move routine for Sort - when N_Real_Literal | - N_String_Literal | - N_Character_Literal => - return; + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); - when N_Range => - Check_Expr_Constants (Low_Bound (Nod)); - Check_Expr_Constants (High_Bound (Nod)); + -------- + -- Lt -- + -------- - when N_Explicit_Dereference => - Check_Expr_Constants (Prefix (Nod)); + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return Component_Bit_Offset (Comps (Op1)) + < + Component_Bit_Offset (Comps (Op2)); + end Lt; - when N_Indexed_Component => - Check_Expr_Constants (Prefix (Nod)); - Check_List_Constants (Expressions (Nod)); + ---------- + -- Move -- + ---------- - when N_Slice => - Check_Expr_Constants (Prefix (Nod)); - Check_Expr_Constants (Discrete_Range (Nod)); + procedure Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end Move; - when N_Selected_Component => - Check_Expr_Constants (Prefix (Nod)); + begin + -- Gather discriminants into Comp - when N_Attribute_Reference => + if DS /= No_List then + Citem := First (DS); + while Present (Citem) loop + if Nkind (Citem) = N_Discriminant_Specification then + declare + Ent : constant Entity_Id := + Defining_Identifier (Citem); + begin + if Ekind (Ent) = E_Discriminant then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Ent; + end if; + end; + end if; - if Attribute_Name (Nod) = Name_Address - or else - Attribute_Name (Nod) = Name_Access - or else - Attribute_Name (Nod) = Name_Unchecked_Access - or else - Attribute_Name (Nod) = Name_Unrestricted_Access - then - Check_At_Constant_Address (Prefix (Nod)); + Next (Citem); + end loop; + end if; - else - Check_Expr_Constants (Prefix (Nod)); - Check_List_Constants (Expressions (Nod)); - end if; + -- Gather component entities into Comp - when N_Aggregate => - Check_List_Constants (Component_Associations (Nod)); - Check_List_Constants (Expressions (Nod)); + Citem := First (Component_Items (CL)); + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Defining_Identifier (Citem); + end if; - when N_Component_Association => - Check_Expr_Constants (Expression (Nod)); + Next (Citem); + end loop; - when N_Extension_Aggregate => - Check_Expr_Constants (Ancestor_Part (Nod)); - Check_List_Constants (Component_Associations (Nod)); - Check_List_Constants (Expressions (Nod)); + -- Now sort the component entities based on the first bit. + -- Note we already know there are no overlapping components. - when N_Null => - return; + Sorting.Sort (Ncomps); - when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In => - Check_Expr_Constants (Left_Opnd (Nod)); - Check_Expr_Constants (Right_Opnd (Nod)); + -- Loop through entries checking for holes - when N_Unary_Op => - Check_Expr_Constants (Right_Opnd (Nod)); + Nbit := Sbit; + for J in 1 .. Ncomps loop + CEnt := Comps (J); + Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit; - when N_Type_Conversion | - N_Qualified_Expression | - N_Allocator => - Check_Expr_Constants (Expression (Nod)); + if Error_Msg_Uint_1 > 0 then + Error_Msg_NE + ("?^-bit gap before component&", + Component_Name (Component_Clause (CEnt)), CEnt); + end if; - when N_Unchecked_Type_Conversion => - Check_Expr_Constants (Expression (Nod)); + Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt); + end loop; - -- If this is a rewritten unchecked conversion, subtypes - -- in this node are those created within the instance. - -- To avoid order of elaboration issues, replace them - -- with their base types. Note that address clauses can - -- cause order of elaboration problems because they are - -- elaborated by the back-end at the point of definition, - -- and may mention entities declared in between (as long - -- as everything is static). It is user-friendly to allow - -- unchecked conversions in this context. + -- Process variant parts recursively if present - if Nkind (Original_Node (Nod)) = N_Function_Call then - Set_Etype (Expression (Nod), - Base_Type (Etype (Expression (Nod)))); - Set_Etype (Nod, Base_Type (Etype (Nod))); - end if; + if Present (Variant_Part (CL)) then + Variant := First (Variants (Variant_Part (CL))); + while Present (Variant) loop + Check_Component_List + (Component_List (Variant), Nbit, No_List); + Next (Variant); + end loop; + end if; + end; + end Check_Component_List; - when N_Function_Call => - if not Is_Pure (Entity (Name (Nod))) then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); + -- Start of processing for Record_Hole_Check - Error_Msg_NE - ("\function & is not pure ('R'M 13.1(22))!", - Nod, Entity (Name (Nod))); + begin + declare + Sbit : Uint; + begin + if Is_Tagged_Type (Rectype) then + Sbit := UI_From_Int (System_Address_Size); else - Check_List_Constants (Parameter_Associations (Nod)); + Sbit := Uint_0; end if; - when N_Parameter_Association => - Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); + if Nkind (Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + then + Check_Component_List + (Component_List (Type_Definition (Decl)), + Sbit, + Discriminant_Specifications (Decl)); + end if; + end; + end Record_Hole_Check; + end if; - when others => - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_NE - ("\must be constant defined before& ('R'M 13.1(22))!", - Nod, U_Ent); - end case; - end Check_Expr_Constants; + -- 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. - -------------------------- - -- Check_List_Constants -- - -------------------------- + -- 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. - procedure Check_List_Constants (Lst : List_Id) is - Nod1 : Node_Id; + -- 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). - begin - if Present (Lst) then - Nod1 := First (Lst); - while Present (Nod1) loop - Check_Expr_Constants (Nod1); - Next (Nod1); - end loop; - end if; - end Check_List_Constants; + if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then - -- Start of processing for Check_Constant_Address_Clause + -- Nothing to do if at least one component has no component clause - begin - Check_Expr_Constants (Expr); - end Check_Constant_Address_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 -- @@ -2953,7 +4115,7 @@ package body Sem_Ch13 is if Siz < M then -- Size is less than minimum size, but one possibility remains - -- that we can manage with the new size if we bias the type + -- that we can manage with the new size if we bias the type. M := UI_From_Int (Minimum_Size (UT, Biased => True)); @@ -3011,6 +4173,8 @@ package body Sem_Ch13 is procedure Initialize is begin + Address_Clause_Checks.Init; + Independence_Checks.Init; Unchecked_Conversions.Init; end Initialize; @@ -3025,9 +4189,8 @@ package body Sem_Ch13 is else declare Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); - begin - return Id = Attribute_Input + return Id = Attribute_Input or else Id = Attribute_Output or else Id = Attribute_Read or else Id = Attribute_Write @@ -3036,19 +4199,6 @@ package body Sem_Ch13 is end if; end Is_Operational_Item; - -------------------------------------- - -- Mark_Aliased_Address_As_Volatile -- - -------------------------------------- - - procedure Mark_Aliased_Address_As_Volatile (N : Node_Id) is - Ent : constant Entity_Id := Address_Aliased_Entity (N); - - begin - if Present (Ent) then - Set_Treat_As_Volatile (Ent); - end if; - end Mark_Aliased_Address_As_Volatile; - ------------------ -- Minimum_Size -- ------------------ @@ -3088,7 +4238,7 @@ package body Sem_Ch13 is -- we have short and long addresses, and it is possible for an access -- type to have a short address size (and thus be less than the size -- of System.Address itself). We simply skip the check for VMS, and - -- leave the back end to do the check. + -- leave it to the back end to do the check. elsif Is_Access_Type (T) then if OpenVMS_On_Target then @@ -3106,9 +4256,9 @@ package body Sem_Ch13 is elsif Is_Discrete_Type (T) then - -- The following loop is looking for the nearest compile time - -- known bounds following the ancestor subtype chain. The idea - -- is to find the most restrictive known bounds information. + -- The following loop is looking for the nearest compile time known + -- bounds following the ancestor subtype chain. The idea is to find + -- the most restrictive known bounds information. Ancest := T; loop @@ -3144,17 +4294,17 @@ package body Sem_Ch13 is end loop; -- Fixed-point types. We can't simply use Expr_Value to get the - -- Corresponding_Integer_Value values of the bounds, since these - -- do not get set till the type is frozen, and this routine can - -- be called before the type is frozen. Similarly the test for - -- bounds being static needs to include the case where we have - -- unanalyzed real literals for the same reason. + -- Corresponding_Integer_Value values of the bounds, since these do not + -- get set till the type is frozen, and this routine can be called + -- before the type is frozen. Similarly the test for bounds being static + -- needs to include the case where we have unanalyzed real literals for + -- the same reason. elsif Is_Fixed_Point_Type (T) then - -- The following loop is looking for the nearest compile time - -- known bounds following the ancestor subtype chain. The idea - -- is to find the most restrictive known bounds information. + -- The following loop is looking for the nearest compile time known + -- bounds following the ancestor subtype chain. The idea is to find + -- the most restrictive known bounds information. Ancest := T; loop @@ -3162,6 +4312,17 @@ package body Sem_Ch13 is return 0; end if; + -- Note: In the following two tests for LoSet and HiSet, it may + -- seem redundant to test for N_Real_Literal here since normally + -- one would assume that the test for the value being known at + -- compile time includes this case. However, there is a glitch. + -- If the real literal comes from folding a non-static expression, + -- then we don't consider any non- static expression to be known + -- at compile time if we are in configurable run time mode (needed + -- in some cases to give a clearer definition of what is and what + -- is not accepted). So the test is indeed needed. Without it, we + -- would set neither Lo_Set nor Hi_Set and get an infinite loop. + if not LoSet then if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal or else Compile_Time_Known_Value (Type_Low_Bound (Ancest)) @@ -3202,9 +4363,12 @@ package body Sem_Ch13 is raise Program_Error; end if; - -- Fall through with Hi and Lo set. Deal with biased case. + -- Fall through with Hi and Lo set. Deal with biased case - if (Biased and then not Is_Fixed_Point_Type (T)) + if (Biased + and then not Is_Fixed_Point_Type (T) + and then not (Is_Enumeration_Type (T) + and then Has_Non_Standard_Rep (T))) or else Has_Biased_Representation (T) then Hi := Hi - Lo; @@ -3212,8 +4376,8 @@ package body Sem_Ch13 is end if; -- Signed case. Note that we consider types like range 1 .. -1 to be - -- signed for the purpose of computing the size, since the bounds - -- have to be accomodated in the base type. + -- signed for the purpose of computing the size, since the bounds have + -- to be accommodated in the base type. if Lo < 0 or else Hi < 0 then S := 1; @@ -3239,106 +4403,32 @@ package body Sem_Ch13 is -- If both bounds are positive, make sure that both are represen- -- table in the case where the bounds are crossed. This can happen -- either because of the way the bounds are declared, or because of - -- the algorithm in Freeze_Fixed_Point_Type. - - if Lo > Hi then - Hi := Lo; - end if; - - -- S = size, (can accommodate 0 .. (2**size - 1)) - - S := 0; - while Hi >= Uint_2 ** S loop - S := S + 1; - end loop; - end if; - - return S; - end Minimum_Size; - - ------------------------- - -- New_Stream_Function -- - ------------------------- - - procedure New_Stream_Function - (N : Node_Id; - Ent : Entity_Id; - Subp : Entity_Id; - Nam : TSS_Name_Type) - is - Loc : constant Source_Ptr := Sloc (N); - Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); - Subp_Id : Entity_Id; - Subp_Decl : Node_Id; - F : Entity_Id; - Etyp : Entity_Id; - - function Build_Spec return Node_Id; - -- Used for declaration and renaming declaration, so that this is - -- treated as a renaming_as_body. - - ---------------- - -- Build_Spec -- - ---------------- - - function Build_Spec return Node_Id is - begin - Subp_Id := Make_Defining_Identifier (Loc, Sname); - - return - Make_Function_Specification (Loc, - Defining_Unit_Name => Subp_Id, - Parameter_Specifications => - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_S), - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Reference_To ( - Designated_Type (Etype (F)), Loc)))), - - Subtype_Mark => - New_Reference_To (Etyp, Loc)); - end Build_Spec; + -- the algorithm in Freeze_Fixed_Point_Type. - -- Start of processing for New_Stream_Function + if Lo > Hi then + Hi := Lo; + end if; - begin - F := First_Formal (Subp); - Etyp := Etype (Subp); + -- S = size, (can accommodate 0 .. (2**size - 1)) - if not Is_Tagged_Type (Ent) then - Subp_Decl := - Make_Subprogram_Declaration (Loc, - Specification => Build_Spec); - Insert_Action (N, Subp_Decl); + S := 0; + while Hi >= Uint_2 ** S loop + S := S + 1; + end loop; end if; - Subp_Decl := - Make_Subprogram_Renaming_Declaration (Loc, - Specification => Build_Spec, - Name => New_Reference_To (Subp, Loc)); - - if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then - Set_TSS (Base_Type (Ent), Subp_Id); - else - Insert_Action (N, Subp_Decl); - Copy_TSS (Subp_Id, Base_Type (Ent)); - end if; - end New_Stream_Function; + return S; + end Minimum_Size; - -------------------------- - -- New_Stream_Procedure -- - -------------------------- + --------------------------- + -- New_Stream_Subprogram -- + --------------------------- - procedure New_Stream_Procedure + procedure New_Stream_Subprogram (N : Node_Id; Ent : Entity_Id; Subp : Entity_Id; - Nam : TSS_Name_Type; - Out_P : Boolean := False) + Nam : TSS_Name_Type) is Loc : constant Source_Ptr := Sloc (N); Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); @@ -3347,6 +4437,14 @@ package body Sem_Ch13 is F : Entity_Id; Etyp : Entity_Id; + Defer_Declaration : constant Boolean := + Is_Tagged_Type (Ent) or else Is_Private_Type (Ent); + -- For a tagged type, there is a declaration for each stream attribute + -- at the freeze point, and we must generate only a completion of this + -- declaration. We do the same for private types, because the full view + -- might be tagged. Otherwise we generate a declaration at the point of + -- the attribute definition clause. + function Build_Spec return Node_Id; -- Used for declaration and renaming declaration, so that this is -- treated as a renaming_as_body. @@ -3356,66 +4454,102 @@ package body Sem_Ch13 is ---------------- function Build_Spec return Node_Id is + Out_P : constant Boolean := (Nam = TSS_Stream_Read); + Formals : List_Id; + Spec : Node_Id; + T_Ref : constant Node_Id := New_Reference_To (Etyp, Loc); + begin Subp_Id := Make_Defining_Identifier (Loc, Sname); - return - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Subp_Id, - Parameter_Specifications => - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_S), - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Reference_To ( - Designated_Type (Etype (F)), Loc))), - - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_V), - Out_Present => Out_P, - Parameter_Type => - New_Reference_To (Etyp, Loc)))); + -- S : access Root_Stream_Type'Class + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To ( + Designated_Type (Etype (F)), Loc)))); + + if Nam = TSS_Stream_Input then + Spec := Make_Function_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals, + Result_Definition => T_Ref); + else + -- V : [out] T + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => Out_P, + Parameter_Type => T_Ref)); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals); + end if; + + return Spec; end Build_Spec; - -- Start of processing for New_Stream_Procedure + -- Start of processing for New_Stream_Subprogram begin - F := First_Formal (Subp); - Etyp := Etype (Next_Formal (F)); + F := First_Formal (Subp); + + if Ekind (Subp) = E_Procedure then + Etyp := Etype (Next_Formal (F)); + else + Etyp := Etype (Subp); + end if; - if not Is_Tagged_Type (Ent) then + -- Prepare subprogram declaration and insert it as an action on the + -- clause node. The visibility for this entity is used to test for + -- visibility of the attribute definition clause (in the sense of + -- 8.3(23) as amended by AI-195). + + if not Defer_Declaration then Subp_Decl := Make_Subprogram_Declaration (Loc, Specification => Build_Spec); - Insert_Action (N, Subp_Decl); + + -- For a tagged type, there is always a visible declaration for each + -- stream TSS (it is a predefined primitive operation), and the + -- completion of this declaration occurs at the freeze point, which is + -- not always visible at places where the attribute definition clause is + -- visible. So, we create a dummy entity here for the purpose of + -- tracking the visibility of the attribute definition clause itself. + + else + Subp_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Sname, 'V')); + Subp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); end if; + Insert_Action (N, Subp_Decl); + Set_Entity (N, Subp_Id); + Subp_Decl := Make_Subprogram_Renaming_Declaration (Loc, Specification => Build_Spec, Name => New_Reference_To (Subp, Loc)); - if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then + if Defer_Declaration then Set_TSS (Base_Type (Ent), Subp_Id); else Insert_Action (N, Subp_Decl); Copy_TSS (Subp_Id, Base_Type (Ent)); end if; - end New_Stream_Procedure; - - --------------------- - -- Record_Rep_Item -- - --------------------- - - procedure Record_Rep_Item (T : Entity_Id; N : Node_Id) is - begin - Set_Next_Rep_Item (N, First_Rep_Item (T)); - Set_First_Rep_Item (T, N); - end Record_Rep_Item; + end New_Stream_Subprogram; ------------------------ -- Rep_Item_Too_Early -- @@ -3423,8 +4557,7 @@ package body Sem_Ch13 is function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is begin - -- Cannot apply rep items that are not operational items - -- to generic types + -- Cannot apply non-operational rep items to generic types if Is_Operational_Item (N) then return False; @@ -3432,12 +4565,11 @@ package body Sem_Ch13 is elsif Is_Type (T) and then Is_Generic_Type (Root_Type (T)) then - Error_Msg_N - ("representation item not allowed for generic type", N); + Error_Msg_N ("representation item not allowed for generic type", N); return True; end if; - -- Otherwise check for incompleted type + -- Otherwise check for incomplete type if Is_Incomplete_Or_Private_Type (T) and then No (Underlying_Type (T)) @@ -3446,7 +4578,7 @@ package body Sem_Ch13 is ("representation item must be after full type declaration", N); return True; - -- If the type has incompleted components, a representation clause is + -- If the type has incomplete components, a representation clause is -- illegal but stream attributes and Convention pragmas are correct. elsif Has_Private_Component (T) then @@ -3476,11 +4608,17 @@ package body Sem_Ch13 is Parent_Type : Entity_Id; procedure Too_Late; - -- Output the too late message + -- Output the too late message. Note that this is not considered a + -- serious error, since the effect is simply that we ignore the + -- representation clause in this case. + + -------------- + -- Too_Late -- + -------------- procedure Too_Late is begin - Error_Msg_N ("representation item appears too late!", N); + Error_Msg_N ("|representation item appears too late!", N); end Too_Late; -- Start of processing for Rep_Item_Too_Late @@ -3498,7 +4636,7 @@ package body Sem_Ch13 is if Present (Freeze_Node (S)) then Error_Msg_NE - ("?no more representation items for }!", Freeze_Node (S), S); + ("?no more representation items for }", Freeze_Node (S), S); end if; return True; @@ -3527,7 +4665,26 @@ package body Sem_Ch13 is end if; end if; - -- No error, link item into head of chain of rep items for the entity + -- No error, link item into head of chain of rep items for the entity, + -- but avoid chaining if we have an overloadable entity, and the pragma + -- is one that can apply to multiple overloaded entities. + + if Is_Overloadable (T) + and then Nkind (N) = N_Pragma + then + declare + Pname : constant Name_Id := Pragma_Name (N); + begin + if Pname = Name_Convention or else + Pname = Name_Import or else + Pname = Name_Export or else + Pname = Name_External or else + Pname = Name_Interface + then + return False; + end if; + end; + end if; Record_Rep_Item (T, N); return False; @@ -3605,8 +4762,8 @@ package body Sem_Ch13 is return not Has_Non_Standard_Rep (T2); end if; - -- Here the two types both have non-standard representation, and we - -- need to determine if they have the same non-standard representation + -- Here the two types both have non-standard representation, and we need + -- to determine if they have the same non-standard representation. -- For arrays, we simply need to test if the component sizes are the -- same. Pragma Pack is reflected in modified component sizes, so this @@ -3661,7 +4818,7 @@ package body Sem_Ch13 is end if; end Same_Rep; - -- Start processing for Record_Case + -- Start of processing for Record_Case begin if Has_Discriminants (T1) then @@ -3704,11 +4861,10 @@ package body Sem_Ch13 is -- For enumeration types, we must check each literal to see if the -- representation is the same. Note that we do not permit enumeration - -- reprsentation clauses for Character and Wide_Character, so these + -- representation clauses for Character and Wide_Character, so these -- cases were already dealt with. elsif Is_Enumeration_Type (T1) then - Enumeration_Case : declare L1, L2 : Entity_Id; @@ -3736,6 +4892,27 @@ package body Sem_Ch13 is end if; end Same_Representation; + ---------------- + -- Set_Biased -- + ---------------- + + procedure Set_Biased + (E : Entity_Id; + N : Node_Id; + Msg : String; + Biased : Boolean := True) + is + begin + if Biased then + Set_Has_Biased_Representation (E); + + if Warn_On_Biased_Representation then + Error_Msg_NE + ("?" & Msg & " forces biased representation for&", N, E); + end if; + end if; + end Set_Biased; + -------------------- -- Set_Enum_Esize -- -------------------- @@ -3791,12 +4968,394 @@ package body Sem_Ch13 is and then Esize (T) < Standard_Integer_Size then Init_Esize (T, Standard_Integer_Size); - else Init_Esize (T, Sz); end if; end Set_Enum_Esize; + ------------------------------ + -- Validate_Address_Clauses -- + ------------------------------ + + procedure Validate_Address_Clauses is + begin + for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop + declare + ACCR : Address_Clause_Check_Record + renames Address_Clause_Checks.Table (J); + + Expr : Node_Id; + + X_Alignment : Uint; + Y_Alignment : Uint; + + X_Size : Uint; + Y_Size : Uint; + + begin + -- Skip processing of this entry if warning already posted + + if not Address_Warning_Posted (ACCR.N) then + + Expr := Original_Node (Expression (ACCR.N)); + + -- Get alignments + + X_Alignment := Alignment (ACCR.X); + Y_Alignment := Alignment (ACCR.Y); + + -- Similarly obtain sizes + + X_Size := Esize (ACCR.X); + Y_Size := Esize (ACCR.Y); + + -- Check for large object overlaying smaller one + + if Y_Size > Uint_0 + and then X_Size > Uint_0 + and then X_Size > Y_Size + then + Error_Msg_NE + ("?& overlays smaller object", ACCR.N, ACCR.X); + Error_Msg_N + ("\?program execution may be erroneous", ACCR.N); + Error_Msg_Uint_1 := X_Size; + Error_Msg_NE + ("\?size of & is ^", ACCR.N, ACCR.X); + Error_Msg_Uint_1 := Y_Size; + Error_Msg_NE + ("\?size of & is ^", ACCR.N, ACCR.Y); + + -- Check for inadequate alignment, both of the base object + -- and of the offset, if any. + + -- Note: we do not check the alignment if we gave a size + -- warning, since it would likely be redundant. + + elsif Y_Alignment /= Uint_0 + and then (Y_Alignment < X_Alignment + or else (ACCR.Off + and then + Nkind (Expr) = N_Attribute_Reference + and then + Attribute_Name (Expr) = Name_Address + and then + Has_Compatible_Alignment + (ACCR.X, Prefix (Expr)) + /= Known_Compatible)) + then + Error_Msg_NE + ("?specified address for& may be inconsistent " + & "with alignment", + ACCR.N, ACCR.X); + Error_Msg_N + ("\?program execution may be erroneous (RM 13.3(27))", + ACCR.N); + Error_Msg_Uint_1 := X_Alignment; + Error_Msg_NE + ("\?alignment of & is ^", + ACCR.N, ACCR.X); + Error_Msg_Uint_1 := Y_Alignment; + Error_Msg_NE + ("\?alignment of & is ^", + ACCR.N, ACCR.Y); + if Y_Alignment >= X_Alignment then + Error_Msg_N + ("\?but offset is not multiple of alignment", + ACCR.N); + end if; + end if; + end if; + end; + 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; + + -- Check actual component size + + if not Known_Component_Size (Atyp) + or else not (Addressable (Component_Size (Atyp)) + and then Component_Size (Atyp) < 64) + 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 64 bits + -- and a multiple of bytes. + + if not Addressable (Esize (C)) + and then Esize (C) < Uint_64 + 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) = E_Discriminant or else Ekind (E) = E_Component 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; + + <> null; + end loop; + end Validate_Independence; + ----------------------------------- -- Validate_Unchecked_Conversion -- ----------------------------------- @@ -3828,8 +5387,8 @@ package body Sem_Ch13 is Target := Ancestor_Subtype (Etype (Act_Unit)); - -- If either type is generic, the instantiation happens within a - -- generic unit, and there is nothing to check. The proper check + -- If either type is generic, the instantiation happens within a generic + -- unit, and there is nothing to check. The proper check -- will happen when the enclosing generic is instantiated. if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then @@ -3852,15 +5411,65 @@ package body Sem_Ch13 is return; end if; - -- Make entry in unchecked conversion table for later processing - -- by Validate_Unchecked_Conversions, which will check sizes and - -- alignments (using values set by the back-end where possible). - -- This is only done if the appropriate warning is active + -- Warn if conversion between two different convention pointers + + if Is_Access_Type (Target) + and then Is_Access_Type (Source) + and then Convention (Target) /= Convention (Source) + and then Warn_On_Unchecked_Conversion + then + -- Give warnings for subprogram pointers only on most targets. The + -- exception is VMS, where data pointers can have different lengths + -- depending on the pointer convention. + + if Is_Access_Subprogram_Type (Target) + or else Is_Access_Subprogram_Type (Source) + or else OpenVMS_On_Target + then + Error_Msg_N + ("?conversion between pointers with different conventions!", N); + end if; + end if; + + -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a + -- warning when compiling GNAT-related sources. + + if Warn_On_Unchecked_Conversion + and then not In_Predefined_Unit (N) + and then RTU_Loaded (Ada_Calendar) + and then + (Chars (Source) = Name_Time + or else + Chars (Target) = Name_Time) + then + -- If Ada.Calendar is loaded and the name of one of the operands is + -- Time, there is a good chance that this is Ada.Calendar.Time. + + declare + Calendar_Time : constant Entity_Id := + Full_View (RTE (RO_CA_Time)); + begin + pragma Assert (Present (Calendar_Time)); + + if Source = Calendar_Time + or else Target = Calendar_Time + then + Error_Msg_N + ("?representation of 'Time values may change between " & + "'G'N'A'T versions", N); + end if; + end; + end if; + + -- Make entry in unchecked conversion table for later processing by + -- Validate_Unchecked_Conversions, which will check sizes and alignments + -- (using values set by the back-end where possible). This is only done + -- if the appropriate warning is active. if Warn_On_Unchecked_Conversion then Unchecked_Conversions.Append (New_Val => UC_Entry' - (Enode => N, + (Eloc => Sloc (N), Source => Source, Target => Target)); @@ -3877,10 +5486,10 @@ package body Sem_Ch13 is end if; end if; - -- If unchecked conversion to access type, and access type is - -- declared in the same unit as the unchecked conversion, then - -- set the No_Strict_Aliasing flag (no strict aliasing is - -- implicit in this situation). + -- If unchecked conversion to access type, and access type is declared + -- in the same unit as the unchecked conversion, then set the + -- No_Strict_Aliasing flag (no strict aliasing is implicit in this + -- situation). if Is_Access_Type (Target) and then In_Same_Source_Unit (Target, N) @@ -3891,7 +5500,7 @@ package body Sem_Ch13 is -- Generate N_Validate_Unchecked_Conversion node for back end in -- case the back end needs to perform special validation checks. - -- Shouldn't this be in exp_ch13, since the check only gets done + -- Shouldn't this be in Exp_Ch13, since the check only gets done -- if we have full expansion and the back end is called ??? Vnode := @@ -3899,8 +5508,8 @@ package body Sem_Ch13 is Set_Source_Type (Vnode, Source); Set_Target_Type (Vnode, Target); - -- If the unchecked conversion node is in a list, just insert before - -- it. If not we have some strange case, not worth bothering about. + -- If the unchecked conversion node is in a list, just insert before it. + -- If not we have some strange case, not worth bothering about. if Is_List_Member (N) then Insert_After (N, Vnode); @@ -3917,39 +5526,46 @@ package body Sem_Ch13 is declare T : UC_Entry renames Unchecked_Conversions.Table (N); - Enode : constant Node_Id := T.Enode; - Source : constant Entity_Id := T.Source; - Target : constant Entity_Id := T.Target; + Eloc : constant Source_Ptr := T.Eloc; + Source : constant Entity_Id := T.Source; + Target : constant Entity_Id := T.Target; Source_Siz : Uint; Target_Siz : Uint; begin - -- This validation check, which warns if we have unequal sizes - -- for unchecked conversion, and thus potentially implementation + -- This validation check, which warns if we have unequal sizes for + -- unchecked conversion, and thus potentially implementation -- dependent semantics, is one of the few occasions on which we - -- use the official RM size instead of Esize. See description - -- in Einfo "Handling of Type'Size Values" for details. + -- use the official RM size instead of Esize. See description in + -- Einfo "Handling of Type'Size Values" for details. if Serious_Errors_Detected = 0 and then Known_Static_RM_Size (Source) and then Known_Static_RM_Size (Target) + + -- Don't do the check if warnings off for either type, note the + -- deliberate use of OR here instead of OR ELSE to get the flag + -- Warnings_Off_Used set for both types if appropriate. + + and then not (Has_Warnings_Off (Source) + or + Has_Warnings_Off (Target)) then Source_Siz := RM_Size (Source); Target_Siz := RM_Size (Target); if Source_Siz /= Target_Siz then - Error_Msg_N - ("types for unchecked conversion have different sizes?", - Enode); + Error_Msg + ("?types for unchecked conversion have different sizes!", + Eloc); if All_Errors_Mode then Error_Msg_Name_1 := Chars (Source); Error_Msg_Uint_1 := Source_Siz; Error_Msg_Name_2 := Chars (Target); Error_Msg_Uint_2 := Target_Siz; - Error_Msg_N - ("\size of % is ^, size of % is ^?", Enode); + Error_Msg ("\size of % is ^, size of % is ^?", Eloc); Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz); @@ -3957,46 +5573,46 @@ package body Sem_Ch13 is and then Is_Discrete_Type (Target) then if Source_Siz > Target_Siz then - Error_Msg_N - ("\^ high order bits of source will be ignored?", - Enode); + Error_Msg + ("\?^ high order bits of source will be ignored!", + Eloc); elsif Is_Unsigned_Type (Source) then - Error_Msg_N - ("\source will be extended with ^ high order " & - "zero bits?", Enode); + Error_Msg + ("\?source will be extended with ^ high order " & + "zero bits?!", Eloc); else - Error_Msg_N - ("\source will be extended with ^ high order " & - "sign bits?", - Enode); + Error_Msg + ("\?source will be extended with ^ high order " & + "sign bits!", + Eloc); end if; elsif Source_Siz < Target_Siz then if Is_Discrete_Type (Target) then if Bytes_Big_Endian then - Error_Msg_N - ("\target value will include ^ undefined " & - "low order bits?", - Enode); + Error_Msg + ("\?target value will include ^ undefined " & + "low order bits!", + Eloc); else - Error_Msg_N - ("\target value will include ^ undefined " & - "high order bits?", - Enode); + Error_Msg + ("\?target value will include ^ undefined " & + "high order bits!", + Eloc); end if; else - Error_Msg_N - ("\^ trailing bits of target value will be " & - "undefined?", Enode); + Error_Msg + ("\?^ trailing bits of target value will be " & + "undefined!", Eloc); end if; else pragma Assert (Source_Siz > Target_Siz); - Error_Msg_N - ("\^ trailing bits of source will be ignored?", - Enode); + Error_Msg + ("\?^ trailing bits of source will be ignored!", + Eloc); end if; end if; end if; @@ -4027,19 +5643,31 @@ package body Sem_Ch13 is begin if Source_Align < Target_Align and then not Is_Tagged_Type (D_Source) + + -- Suppress warning if warnings suppressed on either + -- type or either designated type. Note the use of + -- OR here instead of OR ELSE. That is intentional, + -- we would like to set flag Warnings_Off_Used in + -- all types for which warnings are suppressed. + + and then not (Has_Warnings_Off (D_Source) + or + Has_Warnings_Off (D_Target) + or + Has_Warnings_Off (Source) + or + Has_Warnings_Off (Target)) then Error_Msg_Uint_1 := Target_Align; Error_Msg_Uint_2 := Source_Align; + Error_Msg_Node_1 := D_Target; Error_Msg_Node_2 := D_Source; - Error_Msg_NE - ("alignment of & (^) is stricter than " & - "alignment of & (^)?", Enode, D_Target); - - if All_Errors_Mode then - Error_Msg_N - ("\resulting access value may have invalid " & - "alignment?", Enode); - end if; + Error_Msg + ("?alignment of & (^) is stricter than " & + "alignment of & (^)!", Eloc); + Error_Msg + ("\?resulting access value may have invalid " & + "alignment!", Eloc); end if; end; end if;