diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/sem_ch13.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/sem_ch13.adb | 4589 |
1 files changed, 4589 insertions, 0 deletions
diff --git a/gcc-4.4.3/gcc/ada/sem_ch13.adb b/gcc-4.4.3/gcc/ada/sem_ch13.adb new file mode 100644 index 000000000..d9b626f89 --- /dev/null +++ b/gcc-4.4.3/gcc/ada/sem_ch13.adb @@ -0,0 +1,4589 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C H 1 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2008, 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 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 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. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Checks; use Checks; +with Einfo; use Einfo; +with Errout; use Errout; +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_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_G; + +package body Sem_Ch13 is + + SSU : constant Pos := System_Storage_Unit; + -- Convenient short hand for commonly used constant + + ----------------------- + -- Local Subprograms -- + ----------------------- + + 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 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 have overlapping component clauses and issues errors if so. + + function Get_Alignment_Value (Expr : Node_Id) return Uint; + -- Given the expression for an alignment value, returns the corresponding + -- Uint value. If the value is inappropriate, then error messages are + -- posted as required, and a value of No_Uint is returned. + + function Is_Operational_Item (N : Node_Id) return Boolean; + -- A specification for a stream attribute is allowed before the full + -- type is declared, as explained in AI-00137 and the corrigendum. + -- 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 New_Stream_Subprogram + (N : Node_Id; + Ent : Entity_Id; + Subp : Entity_Id; + Nam : TSS_Name_Type); + -- 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 + -- declaration, so that the attribute specification is handled as a + -- renaming_as_body. For tagged types, the specification is one of the + -- primitive specs. + + ---------------------------------------------- + -- Table for Validate_Unchecked_Conversions -- + ---------------------------------------------- + + -- The following table collects unchecked conversions for validation. + -- Entries are made by Validate_Unchecked_Conversion and then the + -- 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 performed by the back end. + + 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 + end record; + + package Unchecked_Conversions is new Table.Table ( + Table_Component_Type => UC_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Unchecked_Conversions"); + + ---------------------------------------- + -- 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 + 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"); + + ---------------------------- + -- Address_Aliased_Entity -- + ---------------------------- + + 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 + declare + P : Node_Id; + + begin + P := Prefix (N); + while Nkind_In (P, N_Selected_Component, N_Indexed_Component) loop + P := Prefix (P); + end loop; + + if Is_Entity_Name (P) then + return Entity (P); + end if; + end; + end if; + + return Empty; + end Address_Aliased_Entity; + + ----------------------------------------- + -- Adjust_Record_For_Reverse_Bit_Order -- + ----------------------------------------- + + procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is + Max_Machine_Scalar_Size : constant Uint := + UI_From_Int + (Standard_Long_Long_Integer_Size); + -- We use this as the maximum machine scalar size in the sense of AI-133 + + Num_CC : Natural; + Comp : Entity_Id; + SSU : constant Uint := UI_From_Int (System_Storage_Unit); + + begin + -- This first loop through components does two things. First it deals + -- with the case of components with component clauses whose length is + -- greater than the maximum machine scalar size (either accepting them + -- or rejecting as needed). Second, it counts the number of components + -- with component clauses whose length does not exceed this maximum for + -- later processing. + + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + declare + CC : constant Node_Id := Component_Clause (Comp); + + begin + 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; + end; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- 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. + + 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 component list of 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; + + 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 Ada 2005 AI-133. + + Stop := 0; + while Stop < Num_CC loop + Start := Stop + 1; + Stop := Start; + MaxL := + Static_Integer (Last_Bit (Component_Clause (Comps (Start)))); + while Stop < Num_CC loop + if Static_Integer + (Position (Component_Clause (Comps (Stop + 1)))) = + Static_Integer + (Position (Component_Clause (Comps (Stop)))) + then + Stop := Stop + 1; + MaxL := + UI_Max + (MaxL, + Static_Integer + (Last_Bit (Component_Clause (Comps (Stop))))); + else + exit; + end if; + end loop; + + -- Now we have a group of component clauses from Start to Stop + -- whose positions are identical, and MaxL is the maximum last bit + -- value of any of these components. + + -- We need to determine the corresponding machine scalar size. + -- This loop assumes that machine scalar sizes are even, and that + -- each possible machine scalar has twice as many bits as the + -- next smaller one. + + MSS := Max_Machine_Scalar_Size; + while MSS mod 2 = 0 + and then (MSS / 2) >= SSU + and then (MSS / 2) > MaxL + loop + MSS := MSS / 2; + end loop; + + -- Here is where we fix up the Component_Bit_Offset value to + -- account for the reverse bit order. Some examples of what needs + -- to be done for the case of a machine scalar size of 8 are: + + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new + + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 + + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 + + -- The general rule is that the first bit is obtained by + -- subtracting the old ending bit from machine scalar size - 1. + + for C in Start .. Stop loop + declare + Comp : constant Entity_Id := Comps (C); + CC : constant Node_Id := Component_Clause (Comp); + LB : constant Uint := Static_Integer (Last_Bit (CC)); + NFB : constant Uint := MSS - Uint_1 - LB; + NLB : constant Uint := NFB + Esize (Comp) - 1; + Pos : constant Uint := Static_Integer (Position (CC)); + + begin + if Warn_On_Reverse_Bit_Order then + Error_Msg_Uint_1 := MSS; + Error_Msg_N + ("info: reverse bit order in machine " & + "scalar of length^?", First_Bit (CC)); + Error_Msg_Uint_1 := NFB; + Error_Msg_Uint_2 := NLB; + + if Bytes_Big_Endian then + Error_Msg_NE + ("?\info: big-endian range for " + & "component & is ^ .. ^", + First_Bit (CC), Comp); + else + Error_Msg_NE + ("?\info: little-endian range " + & "for component & is ^ .. ^", + First_Bit (CC), Comp); + end if; + end if; + + Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); + Set_Normalized_First_Bit (Comp, NFB mod SSU); + end; + end loop; + end loop; + end; + end Adjust_Record_For_Reverse_Bit_Order; + + -------------------------------------- + -- Alignment_Check_For_Esize_Change -- + -------------------------------------- + + procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is + begin + -- If the alignment is known, and not set by a rep clause, and is + -- inconsistent with the size being set, then reset it to unknown, + -- we assume in this case that the size overrides the inherited + -- alignment, and that the alignment must be recomputed. + + if Known_Alignment (Typ) + and then not Has_Alignment_Clause (Typ) + and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0 + then + Init_Alignment (Typ); + end if; + end Alignment_Check_For_Esize_Change; + + ----------------------- + -- Analyze_At_Clause -- + ----------------------- + + -- An at clause is replaced by the corresponding Address attribute + -- 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 (RM J.7(2))?", N); + Error_Msg_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; + + ----------------------------------------- + -- Analyze_Attribute_Definition_Clause -- + ----------------------------------------- + + procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Nam : constant Node_Id := Name (N); + Attr : constant Name_Id := Chars (N); + Expr : constant Node_Id := Expression (N); + Id : constant Attribute_Id := Get_Attribute_Id (Attr); + Ent : Entity_Id; + U_Ent : Entity_Id; + + FOnly : Boolean := False; + -- Reset to True for subtype specific attribute (Alignment, Size) + -- and for stream attributes, i.e. those cases where in the call + -- to Rep_Item_Too_Late, FOnly is set True so that only the freezing + -- rules are checked. Note that the case of stream attributes is not + -- clear from the RM, but see AI95-00137. Also, the RM seems to + -- 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 + if Ignore_Rep_Clauses then + Rewrite (N, Make_Null_Statement (Sloc (N))); + return; + end if; + + Analyze (Nam); + Ent := Entity (Nam); + + if Rep_Item_Too_Early (Ent, N) then + 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. + + 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. + + 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. + + Ent := Underlying_Type (Ent); + U_Ent := Ent; + Set_Entity (Nam, Ent); + + else + U_Ent := Underlying_Type (Ent); + end if; + + -- Complete other routine error checks + + if Etype (Nam) = Any_Type then + return; + + elsif Scope (Ent) /= Current_Scope then + Error_Msg_N ("entity must be declared in this scope", Nam); + return; + + elsif No (U_Ent) then + U_Ent := Ent; + + elsif Is_Type (U_Ent) + and then not Is_First_Subtype (U_Ent) + and then Id /= Attribute_Object_Size + and then Id /= Attribute_Value_Size + and then not From_At_Mod (N) + then + Error_Msg_N ("cannot specify attribute for subtype", Nam); + return; + end if; + + -- Switch on particular attribute + + case Id is + + ------------- + -- Address -- + ------------- + + -- 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)); + + if Present (Address_Clause (U_Ent)) then + Error_Msg_N ("address already given for &", Nam); + + -- Case of address clause for subprogram + + elsif Is_Subprogram (U_Ent) then + if Has_Homonym (U_Ent) then + Error_Msg_N + ("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. + + -- Above needs more comments, what is too soon about??? + + Set_Has_Delayed_Freeze (U_Ent); + + -- Case of address clause for entry + + elsif Ekind (U_Ent) = E_Entry then + 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 + Error_Msg_N + ("?entry address declared for entry in task type", N); + Error_Msg_N + ("\?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 (RM J.7.1)?", N); + Error_Msg_N + ("\use interrupt procedure instead?", N); + end if; + + -- Case of an address clause for a controlled object which we + -- consider to be erroneous. + + 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 + ("\?Program_Error will be raised at run time", Nam); + 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 + + elsif + Ekind (U_Ent) = E_Variable + or else + Ekind (U_Ent) = E_Constant + then + declare + Expr : constant Node_Id := Expression (N); + Aent : constant Entity_Id := Address_Aliased_Entity (Expr); + Ent_Y : constant Entity_Id := Find_Overlaid_Object (N); + + begin + -- 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; + + -- Overlaying controlled objects is erroneous + + elsif Present (Aent) + and then (Has_Controlled_Component (Etype (Aent)) + or else Is_Controlled (Etype (Aent))) + then + Error_Msg_N + ("?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) + and then Ekind (U_Ent) = E_Constant + and then Ekind (Aent) /= E_Constant + 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 (RM 13.1(6))", Nam); + return; + + -- Imported variables can have an address clause, but then + -- the import is pretty meaningless except to suppress + -- initializations, so we do not need such variables to + -- be statically allocated (and in fact it causes trouble + -- if the address clause is a local value). + + elsif Is_Imported (U_Ent) then + Set_Is_Statically_Allocated (U_Ent, False); + end if; + + -- We mark a possible modification of a variable with an + -- address clause, since it is likely aliasing is occurring. + + Note_Possible_Modification (Nam, Sure => False); + + -- 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. + + if Present (Ent_Y) then + Set_Treat_As_Volatile (Ent_Y); + end if; + + -- Legality checks on the address clause for initialized + -- objects is deferred until the freeze point, because + -- a subsequent pragma might indicate that the object is + -- imported and thus not initialized. + + Set_Has_Delayed_Freeze (U_Ent); + + if Is_Exported (U_Ent) then + Error_Msg_N + ("& cannot be exported if an address clause is given", + Nam); + Error_Msg_N + ("\define and export a variable " & + "that holds its address instead", + Nam); + end if; + + -- Entity has delayed freeze, so we will generate an + -- alignment check at the freeze point unless suppressed. + + 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); + end; + + -- 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 + -- we have not already posted a warning about size/alignment + -- (some warnings of this type are posted in Checks), and if + -- the address clause comes from source. + + if Address_Clause_Overlay_Warnings + and then Comes_From_Source (N) + then + declare + Ent_X : Entity_Id := Empty; + Ent_Y : Entity_Id := Empty; + + begin + Ent_Y := Find_Overlaid_Object (N); + + if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then + Ent_X := Entity (Name (N)); + Address_Clause_Checks.Append ((N, Ent_X, Ent_Y)); + + -- 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 (Ent_Y) + and then Ekind (Ent_X) = E_Variable + then + Set_Overlays_Constant (Ent_X); + end if; + end if; + end; + end if; + + -- Not a valid entity for an address clause + + else + Error_Msg_N ("address cannot be given for &", Nam); + end if; + end Address; + + --------------- + -- Alignment -- + --------------- + + -- Alignment attribute definition clause + + when Attribute_Alignment => Alignment_Block : declare + Align : constant Uint := Get_Alignment_Value (Expr); + + begin + FOnly := True; + + if not Is_Type (U_Ent) + and then Ekind (U_Ent) /= E_Variable + and then Ekind (U_Ent) /= E_Constant + then + Error_Msg_N ("alignment cannot be given for &", Nam); + + elsif Has_Alignment_Clause (U_Ent) then + Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent)); + Error_Msg_N ("alignment clause previously given#", N); + + elsif Align /= No_Uint then + Set_Has_Alignment_Clause (U_Ent); + Set_Alignment (U_Ent, Align); + end if; + end Alignment_Block; + + --------------- + -- Bit_Order -- + --------------- + + -- Bit_Order attribute definition clause + + when Attribute_Bit_Order => Bit_Order : declare + begin + if not Is_Record_Type (U_Ent) then + Error_Msg_N + ("Bit_Order can only be defined for record type", Nam); + + else + Analyze_And_Resolve (Expr, RTE (RE_Bit_Order)); + + if Etype (Expr) = Any_Type then + return; + + elsif not Is_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("Bit_Order requires static expression!", Expr); + + else + if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then + Set_Reverse_Bit_Order (U_Ent, True); + end if; + end if; + end if; + end Bit_Order; + + -------------------- + -- Component_Size -- + -------------------- + + -- Component_Size attribute definition clause + + when Attribute_Component_Size => Component_Size_Case : declare + Csize : constant Uint := Static_Integer (Expr); + Btype : Entity_Id; + Biased : Boolean; + New_Ctyp : Entity_Id; + Decl : Node_Id; + + begin + if not Is_Array_Type (U_Ent) then + Error_Msg_N ("component size requires array type", Nam); + return; + end if; + + Btype := Base_Type (U_Ent); + + if Has_Component_Size_Clause (Btype) then + Error_Msg_N + ("component size clause for& previously given", Nam); + + elsif Csize /= No_Uint then + Check_Size (Expr, Component_Type (Btype), Csize, Biased); + + 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; + + -- 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. 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_Has_Biased_Representation (New_Ctyp, True); + Set_Is_Itype (New_Ctyp, True); + Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); + + Set_Component_Type (Btype, New_Ctyp); + + if Warn_On_Biased_Representation then + Error_Msg_N + ("?component size clause forces biased " + & "representation", N); + end if; + end if; + + Set_Component_Size (Btype, Csize); + + -- For VM case, we ignore component size clauses + + else + -- Give a warning unless we are in GNAT mode, in which case + -- the warning is suppressed since it is not useful. + + if not GNAT_Mode then + Error_Msg_N + ("?component size ignored in this configuration", N); + end if; + end if; + + Set_Has_Component_Size_Clause (Btype, True); + Set_Has_Non_Standard_Rep (Btype, True); + end if; + end Component_Size_Case; + + ------------------ + -- External_Tag -- + ------------------ + + when Attribute_External_Tag => External_Tag : + begin + if not Is_Tagged_Type (U_Ent) then + Error_Msg_N ("should be a tagged type", Nam); + end if; + + Analyze_And_Resolve (Expr, Standard_String); + + if not Is_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("static string required for tag name!", Nam); + end if; + + if VM_Target = No_VM then + Set_Has_External_Tag_Rep_Clause (U_Ent); + elsif not Inspector_Mode then + 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 => + Analyze_Stream_TSS_Definition (TSS_Stream_Input); + Set_Has_Specified_Stream_Input (Ent); + + ------------------- + -- Machine_Radix -- + ------------------- + + -- Machine radix attribute definition clause + + when Attribute_Machine_Radix => Machine_Radix : declare + Radix : constant Uint := Static_Integer (Expr); + + begin + if not Is_Decimal_Fixed_Point_Type (U_Ent) then + Error_Msg_N ("decimal fixed-point type expected for &", Nam); + + elsif Has_Machine_Radix_Clause (U_Ent) then + Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent)); + Error_Msg_N ("machine radix clause previously given#", N); + + elsif Radix /= No_Uint then + Set_Has_Machine_Radix_Clause (U_Ent); + Set_Has_Non_Standard_Rep (Base_Type (U_Ent)); + + if Radix = 2 then + null; + elsif Radix = 10 then + Set_Machine_Radix_10 (U_Ent); + else + Error_Msg_N ("machine radix value must be 2 or 10", Expr); + end if; + end if; + end Machine_Radix; + + ----------------- + -- Object_Size -- + ----------------- + + -- Object_Size attribute definition clause + + when Attribute_Object_Size => Object_Size : declare + Size : constant Uint := Static_Integer (Expr); + + Biased : Boolean; + pragma Warnings (Off, Biased); + + begin + if not Is_Type (U_Ent) then + Error_Msg_N ("Object_Size cannot be given for &", Nam); + + elsif Has_Object_Size_Clause (U_Ent) then + Error_Msg_N ("Object_Size already given for &", Nam); + + else + Check_Size (Expr, U_Ent, Size, Biased); + + if Size /= 8 + and then + Size /= 16 + and then + Size /= 32 + and then + UI_Mod (Size, 64) /= 0 + then + Error_Msg_N + ("Object_Size must be 8, 16, 32, or multiple of 64", + Expr); + end if; + + Set_Esize (U_Ent, Size); + Set_Has_Object_Size_Clause (U_Ent); + Alignment_Check_For_Esize_Change (U_Ent); + end if; + end Object_Size; + + ------------ + -- Output -- + ------------ + + when Attribute_Output => + Analyze_Stream_TSS_Definition (TSS_Stream_Output); + Set_Has_Specified_Stream_Output (Ent); + + ---------- + -- Read -- + ---------- + + when Attribute_Read => + Analyze_Stream_TSS_Definition (TSS_Stream_Read); + Set_Has_Specified_Stream_Read (Ent); + + ---------- + -- Size -- + ---------- + + -- Size attribute definition clause + + when Attribute_Size => Size : declare + Size : constant Uint := Static_Integer (Expr); + Etyp : Entity_Id; + Biased : Boolean; + + begin + FOnly := True; + + if Has_Size_Clause (U_Ent) then + Error_Msg_N ("size already given for &", Nam); + + elsif not Is_Type (U_Ent) + and then Ekind (U_Ent) /= E_Variable + and then Ekind (U_Ent) /= E_Constant + then + Error_Msg_N ("size cannot be given for &", Nam); + + elsif Is_Array_Type (U_Ent) + and then not Is_Constrained (U_Ent) + then + Error_Msg_N + ("size cannot be given for unconstrained array", Nam); + + elsif Size /= No_Uint then + 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 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); + + if Biased and Warn_On_Biased_Representation then + Error_Msg_N + ("?size clause forces biased representation", N); + end if; + end if; + + -- For types set RM_Size and Esize if possible + + 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). + + if Is_Scalar_Type (U_Ent) then + if Size <= System_Storage_Unit then + Init_Esize (U_Ent, System_Storage_Unit); + elsif Size <= 16 then + Init_Esize (U_Ent, 16); + elsif Size <= 32 then + Init_Esize (U_Ent, 32); + else + Set_Esize (U_Ent, (Size + 63) / 64 * 64); + end if; + + -- For all other types, object size = value size. The + -- backend will adjust as needed. + + else + Set_Esize (U_Ent, Size); + end if; + + Alignment_Check_For_Esize_Change (U_Ent); + + -- For objects, set Esize only + + else + if Is_Elementary_Type (Etyp) 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_Uint_2 := Error_Msg_Uint_1 * 8; + Error_Msg_N + ("size for primitive object must be a power of 2" + & " in the range ^-^", N); + end if; + end if; + + Set_Esize (U_Ent, Size); + end if; + + Set_Has_Size_Clause (U_Ent); + end if; + end Size; + + ----------- + -- Small -- + ----------- + + -- Small attribute definition clause + + when Attribute_Small => Small : declare + Implicit_Base : constant Entity_Id := Base_Type (U_Ent); + Small : Ureal; + + begin + Analyze_And_Resolve (Expr, Any_Real); + + if Etype (Expr) = Any_Type then + return; + + elsif not Is_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("small requires static expression!", Expr); + return; + + else + Small := Expr_Value_R (Expr); + + if Small <= Ureal_0 then + Error_Msg_N ("small value must be greater than zero", Expr); + return; + end if; + + end if; + + if not Is_Ordinary_Fixed_Point_Type (U_Ent) then + Error_Msg_N + ("small requires an ordinary fixed point type", Nam); + + elsif Has_Small_Clause (U_Ent) then + Error_Msg_N ("small already given for &", Nam); + + elsif Small > Delta_Value (U_Ent) then + Error_Msg_N + ("small value must not be greater then delta value", Nam); + + else + Set_Small_Value (U_Ent, Small); + Set_Small_Value (Implicit_Base, Small); + Set_Has_Small_Clause (U_Ent); + Set_Has_Small_Clause (Implicit_Base); + Set_Has_Non_Standard_Rep (Implicit_Base); + end if; + end Small; + + ------------------ + -- Storage_Pool -- + ------------------ + + -- Storage_Pool attribute definition clause + + when Attribute_Storage_Pool => Storage_Pool : declare + Pool : Entity_Id; + T : Entity_Id; + + begin + if Ekind (U_Ent) = E_Access_Subprogram_Type then + Error_Msg_N + ("storage pool cannot be given for access-to-subprogram type", + Nam); + return; + + elsif 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))); + + if not Denotes_Variable (Expr) then + Error_Msg_N ("storage pool must be a variable", Expr); + return; + end if; + + if Nkind (Expr) = N_Type_Conversion then + T := Etype (Expression (Expr)); + else + T := Etype (Expr); + end if; + + -- 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 + -- type storage pool. + + if not Is_Entity_Name (Expr) + and then Is_Object_Reference (Expr) + then + Pool := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); + + declare + Rnode : constant Node_Id := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Pool, + Subtype_Mark => + New_Occurrence_Of (Etype (Expr), Loc), + Name => Expr); + + begin + Insert_Before (N, Rnode); + Analyze (Rnode); + Set_Associated_Storage_Pool (U_Ent, Pool); + end; + + elsif Is_Entity_Name (Expr) then + Pool := Entity (Expr); + + -- If pool is a renamed object, get original one. This can + -- happen with an explicit renaming, and within instances. + + while Present (Renamed_Object (Pool)) + and then Is_Entity_Name (Renamed_Object (Pool)) + loop + Pool := Entity (Renamed_Object (Pool)); + end loop; + + if Present (Renamed_Object (Pool)) + and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion + and then Is_Entity_Name (Expression (Renamed_Object (Pool))) + then + Pool := Entity (Expression (Renamed_Object (Pool))); + end if; + + 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)); + Set_Associated_Storage_Pool (U_Ent, Pool); + + else + Error_Msg_N ("incorrect reference to a Storage Pool", Expr); + return; + end if; + end Storage_Pool; + + ------------------ + -- Storage_Size -- + ------------------ + + -- Storage_Size attribute definition clause + + when Attribute_Storage_Size => Storage_Size : declare + Btype : constant Entity_Id := Base_Type (U_Ent); + Sprag : Node_Id; + + begin + if Is_Task_Type (U_Ent) then + Check_Restriction (No_Obsolescent_Features, N); + + 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; + + FOnly := True; + end if; + + 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); + + elsif Has_Storage_Size_Clause (Btype) then + Error_Msg_N ("storage size already given for &", Nam); + + else + Analyze_And_Resolve (Expr, Any_Integer); + + 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; + + if Compile_Time_Known_Value (Expr) + and then Expr_Value (Expr) = 0 + then + Set_No_Pool_Assigned (Btype); + 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; + + ----------------- + -- Stream_Size -- + ----------------- + + when Attribute_Stream_Size => Stream_Size : declare + Size : constant Uint := Static_Integer (Expr); + + begin + if Ada_Version <= Ada_95 then + Check_Restriction (No_Implementation_Attributes, N); + end if; + + if Has_Stream_Size_Clause (U_Ent) then + Error_Msg_N ("Stream_Size already given for &", Nam); + + 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; + + ---------------- + -- Value_Size -- + ---------------- + + -- Value_Size attribute definition clause + + when Attribute_Value_Size => Value_Size : declare + Size : constant Uint := Static_Integer (Expr); + Biased : Boolean; + + 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); + + 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); + + else + if Is_Elementary_Type (U_Ent) then + Check_Size (Expr, U_Ent, Size, Biased); + Set_Has_Biased_Representation (U_Ent, Biased); + + if Biased and Warn_On_Biased_Representation then + Error_Msg_N + ("?value size clause forces biased representation", N); + end if; + end if; + + Set_RM_Size (U_Ent, Size); + end if; + 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 + -- any expression the clause has been analyzed since the expression + -- itself might cause freezing that makes the clause illegal. + + if Rep_Item_Too_Late (U_Ent, N, FOnly) then + return; + end if; + end Analyze_Attribute_Definition_Clause; + + ---------------------------- + -- Analyze_Code_Statement -- + ---------------------------- + + procedure Analyze_Code_Statement (N : Node_Id) is + HSS : constant Node_Id := Parent (N); + SBody : constant Node_Id := Parent (HSS); + Subp : constant Entity_Id := Current_Scope; + Stmt : Node_Id; + Decl : Node_Id; + StmtO : Node_Id; + DeclO : Node_Id; + + begin + -- Analyze and check we get right type, note that this implements the + -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that + -- is the only way that Asm_Insn could possibly be visible. + + Analyze_And_Resolve (Expression (N)); + + if Etype (Expression (N)) = Any_Type then + return; + elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then + Error_Msg_N ("incorrect type for code statement", N); + return; + end if; + + Check_Code_Statement (N); + + -- Make sure we appear in the handled statement sequence of a + -- subprogram (RM 13.8(3)). + + if Nkind (HSS) /= N_Handled_Sequence_Of_Statements + or else Nkind (SBody) /= N_Subprogram_Body + then + Error_Msg_N + ("code statement can only appear in body of subprogram", N); + return; + end if; + + -- Do remaining checks (RM 13.8(3)) if not already done + + if not Is_Machine_Code_Subprogram (Subp) then + Set_Is_Machine_Code_Subprogram (Subp); + + -- No exception handlers allowed + + if Present (Exception_Handlers (HSS)) then + Error_Msg_N + ("exception handlers not permitted in machine code subprogram", + First (Exception_Handlers (HSS))); + end if; + + -- No declarations other than use clauses and pragmas (we allow + -- certain internally generated declarations as well). + + Decl := First (Declarations (SBody)); + while Present (Decl) loop + DeclO := Original_Node (Decl); + if Comes_From_Source (DeclO) + 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", + DeclO); + end if; + + Next (Decl); + end loop; + + -- No statements other than code statements, pragmas, and labels. + -- Again we allow certain internally generated statements. + + Stmt := First (Statements (HSS)); + while Present (Stmt) loop + StmtO := Original_Node (Stmt); + if Comes_From_Source (StmtO) + 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", + StmtO); + end if; + + Next (Stmt); + end loop; + end if; + end Analyze_Code_Statement; + + ----------------------------------------------- + -- Analyze_Enumeration_Representation_Clause -- + ----------------------------------------------- + + procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is + Ident : constant Node_Id := Identifier (N); + Aggr : constant Node_Id := Array_Aggregate (N); + Enumtype : Entity_Id; + Elit : Entity_Id; + Expr : Node_Id; + Assoc : Node_Id; + Choice : Node_Id; + 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)); + Min : Uint; + Max : Uint; + + begin + if Ignore_Rep_Clauses then + return; + end if; + + -- First some basic error checks + + Find_Type (Ident); + Enumtype := Entity (Ident); + + if Enumtype = Any_Type + or else Rep_Item_Too_Early (Enumtype, N) + then + return; + else + Enumtype := Underlying_Type (Enumtype); + end if; + + if not Is_Enumeration_Type (Enumtype) then + Error_Msg_NE + ("enumeration type required, found}", + Ident, First_Subtype (Enumtype)); + return; + end if; + + -- Ignore rep clause on generic actual type. This will already have + -- been flagged on the template as an error, and this is the safest + -- way to ensure we don't get a junk cascaded message in the instance. + + if Is_Generic_Actual_Type (Enumtype) then + return; + + -- Type must be in current scope + + elsif Scope (Enumtype) /= Current_Scope then + Error_Msg_N ("type must be declared in this scope", Ident); + return; + + -- Type must be a first subtype + + elsif not Is_First_Subtype (Enumtype) then + Error_Msg_N ("cannot give enumeration rep clause for subtype", N); + return; + + -- Ignore duplicate rep clause + + elsif Has_Enumeration_Rep_Clause (Enumtype) then + Error_Msg_N ("duplicate enumeration rep clause ignored", N); + return; + + -- Don't allow rep clause for standard [wide_[wide_]]character + + 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 + Set_Has_Enumeration_Rep_Clause (Enumtype); + Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype)); + end if; + + -- Now we process the aggregate. Note that we don't use the normal + -- aggregate code for this purpose, because we don't want any of the + -- normal expansion activities, and a number of special semantic + -- rules apply (including the component type being any integer type) + + Elit := First_Literal (Enumtype); + + -- First the positional entries if any + + if Present (Expressions (Aggr)) then + Expr := First (Expressions (Aggr)); + while Present (Expr) loop + if No (Elit) then + Error_Msg_N ("too many entries in aggregate", Expr); + return; + end if; + + 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; + end if; + + Set_Enumeration_Rep (Elit, Val); + Set_Enumeration_Rep_Expr (Elit, Expr); + Next (Expr); + Next (Elit); + end loop; + end if; + + -- Now process the named entries if present + + if Present (Component_Associations (Aggr)) then + Assoc := First (Component_Associations (Aggr)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + + if Present (Next (Choice)) then + Error_Msg_N + ("multiple choice not allowed here", Next (Choice)); + Err := True; + end if; + + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N ("others choice not allowed here", Choice); + Err := True; + + elsif Nkind (Choice) = N_Range then + -- ??? should allow zero/one element range here + Error_Msg_N ("range not allowed here", Choice); + Err := True; + + else + Analyze_And_Resolve (Choice, Enumtype); + + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Error_Msg_N ("subtype name not allowed here", Choice); + Err := True; + -- ??? should allow static subtype with zero/one entry + + elsif Etype (Choice) = Base_Type (Enumtype) then + if not Is_Static_Expression (Choice) then + Flag_Non_Static_Expr + ("non-static expression used for choice!", Choice); + Err := True; + + else + Elit := Expr_Value_E (Choice); + + if Present (Enumeration_Rep_Expr (Elit)) then + Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit)); + Error_Msg_NE + ("representation for& previously given#", + Choice, Elit); + Err := True; + end if; + + Set_Enumeration_Rep_Expr (Elit, Choice); + + Expr := Expression (Assoc); + Val := Static_Integer (Expr); + + 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; + end if; + + Set_Enumeration_Rep (Elit, Val); + end if; + end if; + end if; + + Next (Assoc); + end loop; + end if; + + -- Aggregate is fully processed. Now we check that a full set of + -- representations was given, and that they are in range and in order. + -- These checks are only done if no other errors occurred. + + if not Err then + Min := No_Uint; + Max := No_Uint; + + Elit := First_Literal (Enumtype); + while Present (Elit) loop + if No (Enumeration_Rep_Expr (Elit)) then + Error_Msg_NE ("missing representation for&!", N, Elit); + + else + Val := Enumeration_Rep (Elit); + + if Min = No_Uint then + Min := Val; + end if; + + if Val /= No_Uint then + if Max /= No_Uint and then Val <= Max then + Error_Msg_NE + ("enumeration value for& not ordered!", + Enumeration_Rep_Expr (Elit), Elit); + end if; + + 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 Val /= Enumeration_Pos (Elit) then + Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); + end if; + end if; + + Next (Elit); + end loop; + + -- Now set proper size information + + declare + Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype)); + + begin + if Has_Size_Clause (Enumtype) then + if Esize (Enumtype) >= Minsize then + null; + + else + Minsize := + UI_From_Int (Minimum_Size (Enumtype, Biased => True)); + + if Esize (Enumtype) < Minsize then + Error_Msg_N ("previously given size is too small", N); + + else + Set_Has_Biased_Representation (Enumtype); + end if; + end if; + + else + Set_RM_Size (Enumtype, Minsize); + Set_Enum_Esize (Enumtype); + end if; + + Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype)); + Set_Esize (Base_Type (Enumtype), Esize (Enumtype)); + Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype)); + end; + end if; + + -- We repeat the too late test in case it froze itself! + + if Rep_Item_Too_Late (Enumtype, N) then + null; + end if; + end Analyze_Enumeration_Representation_Clause; + + ---------------------------- + -- Analyze_Free_Statement -- + ---------------------------- + + procedure Analyze_Free_Statement (N : Node_Id) is + begin + 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 + + Ccount : Natural := 0; + -- Number of component clauses in record rep clause + + CR_Pragma : Node_Id := Empty; + -- Points to N_Pragma node if Complete_Representation pragma present + + 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 Is_Unchecked_Union (Rectype) then + Error_Msg_N + ("record rep clause not allowed for Unchecked_Union", N); + + 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; + + if Present (Mod_Clause (N)) then + declare + Loc : constant Source_Ptr := Sloc (N); + M : constant Node_Id := Mod_Clause (N); + P : constant List_Id := Pragmas_Before (M); + AtM_Nod : Node_Id; + + Mod_Val : Uint; + 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 (RM J.8)?", N); + Error_Msg_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. + + -- This seems dubious, this destroys the source tree in a manner + -- not detectable by ASIS ??? + + if Operating_Mode = Check_Semantics + and then ASIS_Mode + then + AtM_Nod := + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Base_Type (Rectype), Loc), + Chars => Name_Alignment, + Expression => Relocate_Node (Expression (M))); + + Set_From_At_Mod (AtM_Nod); + Insert_After (N, AtM_Nod); + Mod_Val := Get_Alignment_Value (Expression (AtM_Nod)); + Set_Mod_Clause (N, Empty); + + else + -- Get the alignment value to perform error checking + + Mod_Val := Get_Alignment_Value (Expression (M)); + + end if; + end; + end if; + + -- 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. + + if not Is_Tagged_Type (Rectype) then + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + Set_Component_Clause (Comp, Empty); + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + + -- 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; + + -- 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 + + -- 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)); + + if Posit /= No_Uint + and then Fbit /= No_Uint + and then Lbit /= No_Uint + then + if Posit < 0 then + Error_Msg_N + ("position cannot be negative", Position (CC)); + + elsif Fbit < 0 then + 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 + -- tag to get an explicit position. + + elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then + if Attribute_Name (Component_Name (CC)) = Name_Tag then + Error_Msg_N ("position of tag cannot be specified", CC); + else + Error_Msg_N ("illegal component name", CC); + end if; + + else + Comp := First_Entity (Rectype); + while Present (Comp) loop + exit when Chars (Comp) = Chars (Component_Name (CC)); + Next_Entity (Comp); + end loop; + + if No (Comp) then + + -- Maybe component of base type that is absent from + -- statically constrained first subtype. + + Comp := First_Entity (Base_Type (Rectype)); + while Present (Comp) loop + exit when Chars (Comp) = Chars (Component_Name (CC)); + Next_Entity (Comp); + end loop; + end if; + + if No (Comp) then + Error_Msg_N + ("component clause is for non-existent field", CC); + + elsif Present (Component_Clause (Comp)) then + + -- 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); + + else + 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; + + 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 Fbit <= Max_Bit_So_Far then + Overlap_Check_Required := True; + else + Max_Bit_So_Far := Lbit; + end if; + + if Has_Size_Clause (Rectype) + and then Esize (Rectype) <= Lbit + then + Error_Msg_N + ("bit number out of range of specified size", + Last_Bit (CC)); + else + Set_Component_Clause (Comp, CC); + Set_Component_Bit_Offset (Comp, Fbit); + Set_Esize (Comp, 1 + (Lbit - Fbit)); + Set_Normalized_First_Bit (Comp, Fbit mod SSU); + Set_Normalized_Position (Comp, Fbit / SSU); + + Set_Normalized_Position_Max + (Fent, Normalized_Position (Fent)); + + if Is_Tagged_Type (Rectype) + and then Fbit < System_Address_Size + then + Error_Msg_NE + ("component overlaps tag field of&", + CC, Rectype); + end if; + + -- This information is also set in the corresponding + -- component of the base type, found by accessing the + -- Original_Record_Component link if it is present. + + Ocomp := Original_Record_Component (Comp); + + if Hbit < Lbit then + Hbit := Lbit; + end if; + + Check_Size + (Component_Name (CC), + Etype (Comp), + Esize (Comp), + Biased); + + Set_Has_Biased_Representation (Comp, Biased); + + if Biased and Warn_On_Biased_Representation then + Error_Msg_F + ("?component clause forces biased " + & "representation", CC); + end if; + + if Present (Ocomp) then + Set_Component_Clause (Ocomp, CC); + Set_Component_Bit_Offset (Ocomp, Fbit); + Set_Normalized_First_Bit (Ocomp, Fbit mod SSU); + Set_Normalized_Position (Ocomp, Fbit / SSU); + Set_Esize (Ocomp, 1 + (Lbit - Fbit)); + + Set_Normalized_Position_Max + (Ocomp, Normalized_Position (Ocomp)); + + Set_Has_Biased_Representation + (Ocomp, Has_Biased_Representation (Comp)); + end if; + + if Esize (Comp) < 0 then + Error_Msg_N ("component size is negative", CC); + end if; + end if; + end if; + end if; + end if; + end if; + + Next (CC); + end loop; + + -- Now that we have processed all the component clauses, check for + -- overlap. We have to leave this till last, since the components can + -- appear in any arbitrary order in the representation clause. + + -- We do not need this check if all specified ranges were monotonic, + -- as recorded by Overlap_Check_Required being False at this stage. + + -- This first section checks if there are any overlapping entries at + -- all. It does this by sorting all entries and then seeing if there are + -- any overlaps. If there are none, then that is decisive, but if there + -- are overlaps, they may still be OK (they may result from fields in + -- different variants). + + if Overlap_Check_Required then + Overlap_Check1 : declare + + OC_Fbit : array (0 .. Ccount) of Uint; + -- First-bit values for component clauses, the value is the offset + -- of the first bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Lbit : array (0 .. Ccount) of Uint; + -- Last-bit values for component clauses, the value is the offset + -- of the last bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Count : Natural := 0; + -- Count of entries in OC_Fbit and OC_Lbit + + function OC_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure OC_Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); + + function OC_Lt (Op1, Op2 : Natural) return Boolean is + begin + return OC_Fbit (Op1) < OC_Fbit (Op2); + end OC_Lt; + + procedure OC_Move (From : Natural; To : Natural) is + begin + OC_Fbit (To) := OC_Fbit (From); + OC_Lbit (To) := OC_Lbit (From); + end OC_Move; + + begin + CC := First (Component_Clauses (N)); + while Present (CC) loop + if Nkind (CC) /= N_Pragma then + Posit := Static_Integer (Position (CC)); + Fbit := Static_Integer (First_Bit (CC)); + Lbit := Static_Integer (Last_Bit (CC)); + + if Posit /= No_Uint + and then Fbit /= No_Uint + and then Lbit /= No_Uint + then + OC_Count := OC_Count + 1; + Posit := Posit * SSU; + OC_Fbit (OC_Count) := Fbit + Posit; + OC_Lbit (OC_Count) := Lbit + Posit; + end if; + end if; + + Next (CC); + end loop; + + Sorting.Sort (OC_Count); + + Overlap_Check_Required := False; + for J in 1 .. OC_Count - 1 loop + if OC_Lbit (J) >= OC_Fbit (J + 1) then + Overlap_Check_Required := True; + exit; + end if; + end loop; + end Overlap_Check1; + end if; + + -- If Overlap_Check_Required is still True, then we have to do the full + -- scale overlap check, since we have at least two fields that do + -- overlap, and we need to know if that is OK since they are in + -- different variant, or whether we have a definite problem. + + if Overlap_Check_Required then + Overlap_Check2 : declare + C1_Ent, C2_Ent : Entity_Id; + -- Entities of components being checked for overlap + + Clist : Node_Id; + -- Component_List node whose Component_Items are being checked + + Citem : Node_Id; + -- Component declaration for component being checked + + begin + C1_Ent := First_Entity (Base_Type (Rectype)); + + -- Loop through all components in record. For each component check + -- for overlap with any of the preceding elements on the component + -- list containing the component and also, if the component is in + -- a variant, check against components outside the case structure. + -- This latter test is repeated recursively up the variant tree. + + Main_Component_Loop : while Present (C1_Ent) loop + if Ekind (C1_Ent) /= E_Component + and then Ekind (C1_Ent) /= E_Discriminant + then + goto Continue_Main_Component_Loop; + end if; + + -- Skip overlap check if entity has no declaration node. This + -- happens with discriminants in constrained derived types. + -- Probably we are missing some checks as a result, but that + -- does not seem terribly serious ??? + + if No (Declaration_Node (C1_Ent)) then + goto Continue_Main_Component_Loop; + end if; + + Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); + + -- Loop through component lists that need checking. Check the + -- current component list and all lists in variants above us. + + Component_List_Loop : loop + + -- If derived type definition, go to full declaration + -- If at outer level, check discriminants if there are any. + + if Nkind (Clist) = N_Derived_Type_Definition then + Clist := Parent (Clist); + end if; + + -- Outer level of record definition, check discriminants + + if Nkind_In (Clist, N_Full_Type_Declaration, + N_Private_Type_Declaration) + then + if Has_Discriminants (Defining_Identifier (Clist)) then + C2_Ent := + First_Discriminant (Defining_Identifier (Clist)); + + while Present (C2_Ent) loop + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + Next_Discriminant (C2_Ent); + end loop; + end if; + + -- Record extension case + + elsif Nkind (Clist) = N_Derived_Type_Definition then + Clist := Empty; + + -- Otherwise check one component list + + else + Citem := First (Component_Items (Clist)); + + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + C2_Ent := Defining_Identifier (Citem); + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + end if; + + Next (Citem); + end loop; + end if; + + -- Check for variants above us (the parent of the Clist can + -- be a variant, in which case its parent is a variant part, + -- and the parent of the variant part is a component list + -- whose components must all be checked against the current + -- component for overlap). + + if Nkind (Parent (Clist)) = N_Variant then + Clist := Parent (Parent (Parent (Clist))); + + -- Check for possible discriminant part in record, this is + -- treated essentially as another level in the recursion. + -- For this case the parent of the component list is the + -- record definition, and its parent is the full type + -- declaration containing the discriminant specifications. + + elsif Nkind (Parent (Clist)) = N_Record_Definition then + Clist := Parent (Parent ((Clist))); + + -- If neither of these two cases, we are at the top of + -- the tree. + + else + exit Component_List_Loop; + end if; + end loop Component_List_Loop; + + <<Continue_Main_Component_Loop>> + Next_Entity (C1_Ent); + + end loop Main_Component_Loop; + end Overlap_Check2; + end if; + + -- For records that have component clauses for all components, and whose + -- size is less than or equal to 32, we need to know the size in the + -- front end to activate possible packed array processing where the + -- component type is a record. + + -- At this stage Hbit + 1 represents the first unused bit from all the + -- component clauses processed, so if the component clauses are + -- complete, then this is the length of the record. + + -- For records longer than System.Storage_Unit, and for those where not + -- all components have component clauses, the back end determines the + -- length (it may for example be appropriate to round up the size + -- to some convenient boundary, based on alignment considerations, etc). + + if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then + + -- Nothing to do if at least one component has no component clause + + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + exit when No (Component_Clause (Comp)); + Next_Component_Or_Discriminant (Comp); + end loop; + + -- If we fall out of loop, all components have component clauses + -- and so we can set the size to the maximum value. + + if No (Comp) then + Set_RM_Size (Rectype, Hbit + 1); + end if; + end if; + + -- Check missing components if Complete_Representation pragma appeared + + if Present (CR_Pragma) then + 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; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- If no Complete_Representation pragma, warn if missing components + + elsif Warn_On_Unrepped_Components then + declare + Num_Repped_Components : Nat := 0; + Num_Unrepped_Components : Nat := 0; + + begin + -- First count number of repped and unrepped components + + 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; + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- 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. + + 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 + Error_Msg_Sloc := Sloc (Comp); + Error_Msg_NE + ("?no component clause given for & declared #", + N, Comp); + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + end; + end if; + end Analyze_Record_Representation_Clause; + + ----------------------------- + -- Check_Component_Overlap -- + ----------------------------- + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is + begin + if Present (Component_Clause (C1_Ent)) + and then Present (Component_Clause (C2_Ent)) + then + -- Exclude odd case where we have two tag fields in the same record, + -- both at location zero. This seems a bit strange, but it seems to + -- happen in some circumstances ??? + + if Chars (C1_Ent) = Name_uTag + and then Chars (C2_Ent) = Name_uTag + then + return; + end if; + + -- Here we check if the two fields overlap + + declare + S1 : constant Uint := Component_Bit_Offset (C1_Ent); + S2 : constant Uint := Component_Bit_Offset (C2_Ent); + E1 : constant Uint := S1 + Esize (C1_Ent); + E2 : constant Uint := S2 + Esize (C2_Ent); + + begin + if E2 <= S1 or else E1 <= S2 then + null; + else + Error_Msg_Node_2 := + Component_Name (Component_Clause (C2_Ent)); + Error_Msg_Sloc := Sloc (Error_Msg_Node_2); + Error_Msg_Node_1 := + Component_Name (Component_Clause (C1_Ent)); + Error_Msg_N + ("component& overlaps & #", + Component_Name (Component_Clause (C1_Ent))); + end if; + end; + end if; + end Check_Component_Overlap; + + ----------------------------------- + -- Check_Constant_Address_Clause -- + ----------------------------------- + + 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. + + 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. + + 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. + + ------------------------------- + -- Check_At_Constant_Address -- + ------------------------------- + + 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); + + 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 % (RM 13.1(22))!", + Nod); + end if; + + elsif Nkind (Nod) = N_Selected_Component then + declare + T : constant Entity_Id := Etype (Prefix (Nod)); + + 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; + + elsif Nkind (Nod) = N_Indexed_Component then + Check_At_Constant_Address (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); + + 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 (Ent) = E_Named_Integer + or else + Ekind (Ent) = 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_Name_1 := Chars (Ent); + Error_Msg_Name_2 := Chars (U_Ent); + Error_Msg_N + ("\% must be defined before % (RM 13.1(22))!", + Nod); + 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_Name_1 := Chars (Ent); + Error_Msg_N + ("\reference to variable% not allowed" + & " (RM 13.1(22))!", Nod); + 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_And_Then | N_Or_Else | 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 + Check_Expr_Constants (Expr); + end Check_Constant_Address_Clause; + + ---------------- + -- Check_Size -- + ---------------- + + procedure Check_Size + (N : Node_Id; + T : Entity_Id; + Siz : Uint; + Biased : out Boolean) + is + UT : constant Entity_Id := Underlying_Type (T); + M : Uint; + + begin + Biased := False; + + -- Dismiss cases for generic types or types with previous errors + + if No (UT) + or else UT = Any_Type + or else Is_Generic_Type (UT) + or else Is_Generic_Type (Root_Type (UT)) + then + return; + + -- Check case of bit packed array + + elsif Is_Array_Type (UT) + and then Known_Static_Component_Size (UT) + and then Is_Bit_Packed_Array (UT) + then + declare + Asiz : Uint; + Indx : Node_Id; + Ityp : Entity_Id; + + begin + Asiz := Component_Size (UT); + Indx := First_Index (UT); + loop + Ityp := Etype (Indx); + + -- If non-static bound, then we are not in the business of + -- trying to check the length, and indeed an error will be + -- issued elsewhere, since sizes of non-static array types + -- cannot be set implicitly or explicitly. + + if not Is_Static_Subtype (Ityp) then + return; + end if; + + -- Otherwise accumulate next dimension + + Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) - + Expr_Value (Type_Low_Bound (Ityp)) + + Uint_1); + + Next_Index (Indx); + exit when No (Indx); + end loop; + + if Asiz <= Siz then + return; + else + Error_Msg_Uint_1 := Asiz; + Error_Msg_NE + ("size for& too small, minimum allowed is ^", N, T); + Set_Esize (T, Asiz); + Set_RM_Size (T, Asiz); + end if; + end; + + -- All other composite types are ignored + + elsif Is_Composite_Type (UT) then + return; + + -- For fixed-point types, don't check minimum if type is not frozen, + -- since we don't know all the characteristics of the type that can + -- affect the size (e.g. a specified small) till freeze time. + + elsif Is_Fixed_Point_Type (UT) + and then not Is_Frozen (UT) + then + null; + + -- Cases for which a minimum check is required + + else + -- Ignore if specified size is correct for the type + + if Known_Esize (UT) and then Siz = Esize (UT) then + return; + end if; + + -- Otherwise get minimum size + + M := UI_From_Int (Minimum_Size (UT)); + + 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. + + M := UI_From_Int (Minimum_Size (UT, Biased => True)); + + if Siz < M then + Error_Msg_Uint_1 := M; + Error_Msg_NE + ("size for& too small, minimum allowed is ^", N, T); + Set_Esize (T, M); + Set_RM_Size (T, M); + else + Biased := True; + end if; + end if; + end if; + end Check_Size; + + ------------------------- + -- Get_Alignment_Value -- + ------------------------- + + function Get_Alignment_Value (Expr : Node_Id) return Uint is + Align : constant Uint := Static_Integer (Expr); + + begin + if Align = No_Uint then + return No_Uint; + + elsif Align <= 0 then + Error_Msg_N ("alignment value must be positive", Expr); + return No_Uint; + + else + for J in Int range 0 .. 64 loop + declare + M : constant Uint := Uint_2 ** J; + + begin + exit when M = Align; + + if M > Align then + Error_Msg_N + ("alignment value must be power of 2", Expr); + return No_Uint; + end if; + end; + end loop; + + return Align; + end if; + end Get_Alignment_Value; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Unchecked_Conversions.Init; + end Initialize; + + ------------------------- + -- Is_Operational_Item -- + ------------------------- + + function Is_Operational_Item (N : Node_Id) return Boolean is + begin + if Nkind (N) /= N_Attribute_Definition_Clause then + return False; + else + declare + Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); + begin + return Id = Attribute_Input + or else Id = Attribute_Output + or else Id = Attribute_Read + or else Id = Attribute_Write + or else Id = Attribute_External_Tag; + end; + end if; + end Is_Operational_Item; + + ------------------ + -- Minimum_Size -- + ------------------ + + function Minimum_Size + (T : Entity_Id; + Biased : Boolean := False) return Nat + is + Lo : Uint := No_Uint; + Hi : Uint := No_Uint; + LoR : Ureal := No_Ureal; + HiR : Ureal := No_Ureal; + LoSet : Boolean := False; + HiSet : Boolean := False; + B : Uint; + S : Nat; + Ancest : Entity_Id; + R_Typ : constant Entity_Id := Root_Type (T); + + begin + -- If bad type, return 0 + + if T = Any_Type then + return 0; + + -- For generic types, just return zero. There cannot be any legitimate + -- need to know such a size, but this routine may be called with a + -- generic type as part of normal processing. + + elsif Is_Generic_Type (R_Typ) + or else R_Typ = Any_Type + then + return 0; + + -- Access types. Normally an access type cannot have a size smaller + -- than the size of System.Address. The exception is on VMS, where + -- 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 it to the back end to do the check. + + elsif Is_Access_Type (T) then + if OpenVMS_On_Target then + return 0; + else + return System_Address_Size; + end if; + + -- Floating-point types + + elsif Is_Floating_Point_Type (T) then + return UI_To_Int (Esize (R_Typ)); + + -- Discrete types + + 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. + + Ancest := T; + loop + if Ancest = Any_Type or else Etype (Ancest) = Any_Type then + return 0; + end if; + + if not LoSet then + if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then + Lo := Expr_Rep_Value (Type_Low_Bound (Ancest)); + LoSet := True; + exit when HiSet; + end if; + end if; + + if not HiSet then + if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then + Hi := Expr_Rep_Value (Type_High_Bound (Ancest)); + HiSet := True; + exit when LoSet; + end if; + end if; + + Ancest := Ancestor_Subtype (Ancest); + + if No (Ancest) then + Ancest := Base_Type (T); + + if Is_Generic_Type (Ancest) then + return 0; + end if; + end if; + 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. + + 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. + + Ancest := T; + loop + if Ancest = Any_Type or else Etype (Ancest) = Any_Type then + 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)) + then + LoR := Expr_Value_R (Type_Low_Bound (Ancest)); + LoSet := True; + exit when HiSet; + end if; + end if; + + if not HiSet then + if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal + or else Compile_Time_Known_Value (Type_High_Bound (Ancest)) + then + HiR := Expr_Value_R (Type_High_Bound (Ancest)); + HiSet := True; + exit when LoSet; + end if; + end if; + + Ancest := Ancestor_Subtype (Ancest); + + if No (Ancest) then + Ancest := Base_Type (T); + + if Is_Generic_Type (Ancest) then + return 0; + end if; + end if; + end loop; + + Lo := UR_To_Uint (LoR / Small_Value (T)); + Hi := UR_To_Uint (HiR / Small_Value (T)); + + -- No other types allowed + + else + raise Program_Error; + end if; + + -- Fall through with Hi and Lo set. Deal with biased case + + 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; + Lo := Uint_0; + 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 accommodated in the base type. + + if Lo < 0 or else Hi < 0 then + S := 1; + B := Uint_1; + + -- S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) + -- Note that we accommodate the case where the bounds cross. This + -- can happen either because of the way the bounds are declared + -- or because of the algorithm in Freeze_Fixed_Point_Type. + + while Lo < -B + or else Hi < -B + or else Lo >= B + or else Hi >= B + loop + B := Uint_2 ** S; + S := S + 1; + end loop; + + -- Unsigned case + + else + -- 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_Subprogram -- + --------------------------- + + procedure New_Stream_Subprogram + (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; + + 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. + + ---------------- + -- Build_Spec -- + ---------------- + + 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); + + -- 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_Subprogram + + begin + F := First_Formal (Subp); + + if Ekind (Subp) = E_Procedure then + Etyp := Etype (Next_Formal (F)); + else + Etyp := Etype (Subp); + end if; + + -- 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); + + -- 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 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_Subprogram; + + ------------------------ + -- Rep_Item_Too_Early -- + ------------------------ + + function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is + begin + -- Cannot apply non-operational rep items to generic types + + if Is_Operational_Item (N) then + return False; + + elsif Is_Type (T) + and then Is_Generic_Type (Root_Type (T)) + then + Error_Msg_N + ("representation item not allowed for generic type", N); + return True; + end if; + + -- Otherwise check for incomplete type + + if Is_Incomplete_Or_Private_Type (T) + and then No (Underlying_Type (T)) + then + Error_Msg_N + ("representation item must be after full type declaration", N); + return True; + + -- 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 + if Nkind (N) = N_Pragma then + return False; + else + Error_Msg_N + ("representation item must appear after type is fully defined", + N); + return True; + end if; + else + return False; + end if; + end Rep_Item_Too_Early; + + ----------------------- + -- Rep_Item_Too_Late -- + ----------------------- + + function Rep_Item_Too_Late + (T : Entity_Id; + N : Node_Id; + FOnly : Boolean := False) return Boolean + is + S : Entity_Id; + Parent_Type : Entity_Id; + + procedure Too_Late; + -- 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); + end Too_Late; + + -- Start of processing for Rep_Item_Too_Late + + begin + -- First make sure entity is not frozen (RM 13.1(9)). Exclude imported + -- types, which may be frozen if they appear in a representation clause + -- for a local type. + + if Is_Frozen (T) + and then not From_With_Type (T) + then + Too_Late; + S := First_Subtype (T); + + if Present (Freeze_Node (S)) then + Error_Msg_NE + ("?no more representation items for }", Freeze_Node (S), S); + end if; + + return True; + + -- Check for case of non-tagged derived type whose parent either has + -- primitive operations, or is a by reference type (RM 13.1(10)). + + elsif Is_Type (T) + and then not FOnly + and then Is_Derived_Type (T) + and then not Is_Tagged_Type (T) + then + Parent_Type := Etype (Base_Type (T)); + + if Has_Primitive_Operations (Parent_Type) then + Too_Late; + Error_Msg_NE + ("primitive operations already defined for&!", N, Parent_Type); + return True; + + elsif Is_By_Reference_Type (Parent_Type) then + Too_Late; + Error_Msg_NE + ("parent type & is a by reference type!", N, Parent_Type); + return True; + end if; + end if; + + -- 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; + end Rep_Item_Too_Late; + + ------------------------- + -- Same_Representation -- + ------------------------- + + function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is + T1 : constant Entity_Id := Underlying_Type (Typ1); + T2 : constant Entity_Id := Underlying_Type (Typ2); + + begin + -- A quick check, if base types are the same, then we definitely have + -- the same representation, because the subtype specific representation + -- attributes (Size and Alignment) do not affect representation from + -- the point of view of this test. + + if Base_Type (T1) = Base_Type (T2) then + return True; + + elsif Is_Private_Type (Base_Type (T2)) + and then Base_Type (T1) = Full_View (Base_Type (T2)) + then + return True; + end if; + + -- Tagged types never have differing representations + + if Is_Tagged_Type (T1) then + return True; + end if; + + -- Representations are definitely different if conventions differ + + if Convention (T1) /= Convention (T2) then + return False; + end if; + + -- Representations are different if component alignments differ + + if (Is_Record_Type (T1) or else Is_Array_Type (T1)) + and then + (Is_Record_Type (T2) or else Is_Array_Type (T2)) + and then Component_Alignment (T1) /= Component_Alignment (T2) + then + return False; + end if; + + -- For arrays, the only real issue is component size. If we know the + -- component size for both arrays, and it is the same, then that's + -- good enough to know we don't have a change of representation. + + if Is_Array_Type (T1) then + if Known_Component_Size (T1) + and then Known_Component_Size (T2) + and then Component_Size (T1) = Component_Size (T2) + then + return True; + end if; + end if; + + -- Types definitely have same representation if neither has non-standard + -- representation since default representations are always consistent. + -- If only one has non-standard representation, and the other does not, + -- then we consider that they do not have the same representation. They + -- might, but there is no way of telling early enough. + + if Has_Non_Standard_Rep (T1) then + if not Has_Non_Standard_Rep (T2) then + return False; + end if; + else + 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. + + -- For arrays, we simply need to test if the component sizes are the + -- same. Pragma Pack is reflected in modified component sizes, so this + -- check also deals with pragma Pack. + + if Is_Array_Type (T1) then + return Component_Size (T1) = Component_Size (T2); + + -- Tagged types always have the same representation, because it is not + -- possible to specify different representations for common fields. + + elsif Is_Tagged_Type (T1) then + return True; + + -- Case of record types + + elsif Is_Record_Type (T1) then + + -- Packed status must conform + + if Is_Packed (T1) /= Is_Packed (T2) then + return False; + + -- Otherwise we must check components. Typ2 maybe a constrained + -- subtype with fewer components, so we compare the components + -- of the base types. + + else + Record_Case : declare + CD1, CD2 : Entity_Id; + + function Same_Rep return Boolean; + -- CD1 and CD2 are either components or discriminants. This + -- function tests whether the two have the same representation + + -------------- + -- Same_Rep -- + -------------- + + function Same_Rep return Boolean is + begin + if No (Component_Clause (CD1)) then + return No (Component_Clause (CD2)); + + else + return + Present (Component_Clause (CD2)) + and then + Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) + and then + Esize (CD1) = Esize (CD2); + end if; + end Same_Rep; + + -- Start processing for Record_Case + + begin + if Has_Discriminants (T1) then + CD1 := First_Discriminant (T1); + CD2 := First_Discriminant (T2); + + -- The number of discriminants may be different if the + -- derived type has fewer (constrained by values). The + -- invisible discriminants retain the representation of + -- the original, so the discrepancy does not per se + -- indicate a different representation. + + while Present (CD1) + and then Present (CD2) + loop + if not Same_Rep then + return False; + else + Next_Discriminant (CD1); + Next_Discriminant (CD2); + end if; + end loop; + end if; + + CD1 := First_Component (Underlying_Type (Base_Type (T1))); + CD2 := First_Component (Underlying_Type (Base_Type (T2))); + + while Present (CD1) loop + if not Same_Rep then + return False; + else + Next_Component (CD1); + Next_Component (CD2); + end if; + end loop; + + return True; + end Record_Case; + end if; + + -- For enumeration types, we must check each literal to see if the + -- representation is the same. Note that we do not permit enumeration + -- 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; + + begin + L1 := First_Literal (T1); + L2 := First_Literal (T2); + + while Present (L1) loop + if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then + return False; + else + Next_Literal (L1); + Next_Literal (L2); + end if; + end loop; + + return True; + + end Enumeration_Case; + + -- Any other types have the same representation for these purposes + + else + return True; + end if; + end Same_Representation; + + -------------------- + -- Set_Enum_Esize -- + -------------------- + + procedure Set_Enum_Esize (T : Entity_Id) is + Lo : Uint; + Hi : Uint; + Sz : Nat; + + begin + Init_Alignment (T); + + -- Find the minimum standard size (8,16,32,64) that fits + + Lo := Enumeration_Rep (Entity (Type_Low_Bound (T))); + Hi := Enumeration_Rep (Entity (Type_High_Bound (T))); + + if Lo < 0 then + if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then + Sz := Standard_Character_Size; -- May be > 8 on some targets + + elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then + Sz := 16; + + elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then + Sz := 32; + + else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63); + Sz := 64; + end if; + + else + if Hi < Uint_2**08 then + Sz := Standard_Character_Size; -- May be > 8 on some targets + + elsif Hi < Uint_2**16 then + Sz := 16; + + elsif Hi < Uint_2**32 then + Sz := 32; + + else pragma Assert (Hi < Uint_2**63); + Sz := 64; + end if; + end if; + + -- That minimum is the proper size unless we have a foreign convention + -- and the size required is 32 or less, in which case we bump the size + -- up to 32. This is required for C and C++ and seems reasonable for + -- all other foreign conventions. + + if Has_Foreign_Convention (T) + 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); + + 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 + + -- Get alignments. Really we should always have the alignment + -- of the objects properly back annotated, but right now the + -- back end fails to back annotate for address clauses??? + + if Known_Alignment (ACCR.X) then + X_Alignment := Alignment (ACCR.X); + else + X_Alignment := Alignment (Etype (ACCR.X)); + end if; + + if Known_Alignment (ACCR.Y) then + Y_Alignment := Alignment (ACCR.Y); + else + Y_Alignment := Alignment (Etype (ACCR.Y)); + end if; + + -- Similarly obtain sizes + + if Known_Esize (ACCR.X) then + X_Size := Esize (ACCR.X); + else + X_Size := Esize (Etype (ACCR.X)); + end if; + + if Known_Esize (ACCR.Y) then + Y_Size := Esize (ACCR.Y); + else + Y_Size := Esize (Etype (ACCR.Y)); + end if; + + -- 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_N + ("?size for overlaid object is too small", 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. Again the defensive check + -- on Y_Alignment should not be needed, but because of the + -- failure in back end annotation, we can have an alignment + -- of 0 here??? + + -- Note: we do not check alignments if we gave a size + -- warning, since it would likely be redundant. + + elsif Y_Alignment /= Uint_0 + and then Y_Alignment < X_Alignment + 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); + end if; + end if; + end; + end loop; + end Validate_Address_Clauses; + + ----------------------------------- + -- Validate_Unchecked_Conversion -- + ----------------------------------- + + procedure Validate_Unchecked_Conversion + (N : Node_Id; + Act_Unit : Entity_Id) + is + Source : Entity_Id; + Target : Entity_Id; + Vnode : Node_Id; + + begin + -- Obtain source and target types. Note that we call Ancestor_Subtype + -- here because the processing for generic instantiation always makes + -- subtypes, and we want the original frozen actual types. + + -- If we are dealing with private types, then do the check on their + -- fully declared counterparts if the full declarations have been + -- encountered (they don't have to be visible, but they must exist!) + + Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit))); + + if Is_Private_Type (Source) + and then Present (Underlying_Type (Source)) + then + Source := Underlying_Type (Source); + end if; + + 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 + -- will happen when the enclosing generic is instantiated. + + if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then + return; + end if; + + if Is_Private_Type (Target) + and then Present (Underlying_Type (Target)) + then + Target := Underlying_Type (Target); + end if; + + -- Source may be unconstrained array, but not target + + if Is_Array_Type (Target) + and then not Is_Constrained (Target) + then + Error_Msg_N + ("unchecked conversion to unconstrained array not allowed", N); + return; + end if; + + -- 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, + Source => Source, + Target => Target)); + + -- If both sizes are known statically now, then back end annotation + -- is not required to do a proper check but if either size is not + -- known statically, then we need the annotation. + + if Known_Static_RM_Size (Source) + and then Known_Static_RM_Size (Target) + then + null; + else + Back_Annotate_Rep_Info := True; + 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 Is_Access_Type (Target) and then + In_Same_Source_Unit (Target, N) + then + Set_No_Strict_Aliasing (Implementation_Base_Type (Target)); + end if; + + -- 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 + -- if we have full expansion and the back end is called ??? + + Vnode := + Make_Validate_Unchecked_Conversion (Sloc (N)); + 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 Is_List_Member (N) then + Insert_After (N, Vnode); + end if; + end Validate_Unchecked_Conversion; + + ------------------------------------ + -- Validate_Unchecked_Conversions -- + ------------------------------------ + + procedure Validate_Unchecked_Conversions is + begin + for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop + 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; + + Source_Siz : Uint; + Target_Siz : Uint; + + begin + -- 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. + + if Serious_Errors_Detected = 0 + and then Known_Static_RM_Size (Source) + and then Known_Static_RM_Size (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); + + 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_Uint_1 := UI_Abs (Source_Siz - Target_Siz); + + if Is_Discrete_Type (Source) + 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); + + elsif Is_Unsigned_Type (Source) then + Error_Msg_N + ("\?source will be extended with ^ high order " & + "zero bits?!", Enode); + + else + Error_Msg_N + ("\?source will be extended with ^ high order " & + "sign bits!", + Enode); + 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); + else + Error_Msg_N + ("\?target value will include ^ undefined " & + "high order bits!", + Enode); + end if; + + else + Error_Msg_N + ("\?^ trailing bits of target value will be " & + "undefined!", Enode); + end if; + + else pragma Assert (Source_Siz > Target_Siz); + Error_Msg_N + ("\?^ trailing bits of source will be ignored!", + Enode); + end if; + end if; + end if; + end if; + + -- If both types are access types, we need to check the alignment. + -- If the alignment of both is specified, we can do it here. + + if Serious_Errors_Detected = 0 + and then Ekind (Source) in Access_Kind + and then Ekind (Target) in Access_Kind + and then Target_Strict_Alignment + and then Present (Designated_Type (Source)) + and then Present (Designated_Type (Target)) + then + declare + D_Source : constant Entity_Id := Designated_Type (Source); + D_Target : constant Entity_Id := Designated_Type (Target); + + begin + if Known_Alignment (D_Source) + and then Known_Alignment (D_Target) + then + declare + Source_Align : constant Uint := Alignment (D_Source); + Target_Align : constant Uint := Alignment (D_Target); + + begin + if Source_Align < Target_Align + and then not Is_Tagged_Type (D_Source) + then + Error_Msg_Uint_1 := Target_Align; + Error_Msg_Uint_2 := Source_Align; + 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; + end if; + end; + end if; + end; + end if; + end; + end loop; + end Validate_Unchecked_Conversions; + +end Sem_Ch13; |