Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / sem_ch13.adb < prev next >

Wrap

Text File | 1996-09-28 | 52KB | 1,520 lines

----------------------------------------------------------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 1 3 -- -- -- -- B o d y -- -- -- -- $Revision: 1.170 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Errout; use Errout; with Features; use Features; with Freeze; use Freeze; with Lib; use Lib; with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Ttypes; use Ttypes; with Uintp; use Uintp; with Urealp; use Urealp; package body Sem_Ch13 is ----------------------- -- Local Subprograms -- ----------------------- function Already_Frozen (T : Entity_Id; N : Node_Id) return Boolean; -- Called at the start of processing a representation clause. Used to -- check that type T, referenced by representation clause N, is not -- already frozen. If the type is not frozen, then False is returned, -- and the caller can proceed. If the type is frozen, then an error -- message is issued and True is returned (which is a signal to the -- caller to abandon processing of the too late rep clause). procedure Check_Size (N : Node_Id; T : Entity_Id; Siz : Uint); -- Called when size S is specified for subtype T. This subprogram checks -- that the size is appropriate, posting errors on node N as required. -- For non-elementary types, a check is only made if an explicit size -- has been given for the type (and the specified size must match) -------------------- -- Already_Frozen -- -------------------- function Already_Frozen (T : Entity_Id; N : Node_Id) return Boolean is S : Entity_Id; begin if Is_Frozen (T) then Error_Msg_N ("rep clause appears too late", N); S := First_Subtype (T); if Present (Freeze_Node (S)) then Error_Msg_NE ("?no more rep clauses for }", Freeze_Node (S), T); end if; return True; else return False; end if; end Already_Frozen; ----------------------- -- 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 begin Rewrite_Substitute_Tree (N, Make_Attribute_Definition_Clause (Sloc (N), Name => Identifier (N), Chars => Name_Address, Expression => Expression (N))); Analyze (N); end Analyze_At_Clause; ----------------------------------------- -- Analyze_Attribute_Definition_Clause -- ----------------------------------------- procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is 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); Typ : Node_Id; Ent : Entity_Id; begin Analyze (Nam); Ent := Entity (Nam); -- 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). Ent := Underlying_Type (Ent); if No (Ent) then Error_Msg_N ("premature reference to incomplete/private type", Nam); return; end if; -- Ignore rep clause for junk entity if Etype (Nam) = Any_Type then return; end if; -- Require first named subtype if Is_Type (Ent) and then not Is_First_Subtype (Ent) then Error_Msg_N ("cannot specify attribute for subtype", Nam); return; end if; -- Check not already frozen if Already_Frozen (Ent, Nam) then return; end if; -- Switch on particular attribute case Id is ------------- -- Address -- ------------- -- Address attribute definition clause when Attribute_Address => Address : begin Note_Feature (New_Representation_Clauses, Sloc (N)); if Present (Address_Clause (Ent)) then Error_Msg_N ("address already given for &", Nam); elsif Ekind (Ent) not in Subprogram_Kind and then Ekind (Ent) /= E_Variable and then Ekind (Ent) /= E_Constant and then (Ekind (Ent) /= E_Entry or else not Is_Task_Type (Scope (Ent))) then Error_Msg_N ("address cannot be given for &", Nam); else Analyze (Expr); Resolve (Expr, RTE (RE_Address)); -- Only allowable expression is prior defined constant if Nkind (Expr) = N_Identifier then declare Entx : constant Entity_Id := Entity (Expr); Locx : constant Source_Ptr := Sloc (Entx); Loce : constant Source_Ptr := Sloc (Ent); begin -- The entity must be a constant, and its location must -- be either less than the source location of the entity -- being given an address (meaning that it is declared -- either before the entity in the current unit, or in -- another unit), or greater than the last source -- location of the current unit, which means that it -- is in some other unit. if (Ekind (Entx) = E_Constant or else Ekind (Entx) = E_In_Parameter) and then (Locx < Loce or else Locx > Source_Last (Source_Index (Current_Sem_Unit))) then Set_Address_Clause (Ent, N); return; end if; end; end if; Error_Msg_NE ("invalid address clause for &!", N, Ent); Error_Msg_N ("must be prior defined constant!", N); end if; end Address; --------------- -- Alignment -- --------------- -- Alignment attribute definition clause when Attribute_Alignment => Alignment : declare Align : Uint := Static_Integer (Expr); begin Note_Feature (New_Representation_Clauses, Sloc (N)); if not Is_Type (Ent) and then Ekind (Ent) /= E_Variable and then Ekind (Ent) /= E_Constant then Error_Msg_N ("alignment cannot be given for &", Nam); elsif Has_Alignment_Clause (Ent) then Error_Msg_Sloc := Sloc (Alignment_Clause (Ent)); Error_Msg_N ("alignment clause previously given#", N); elsif Align /= No_Uint then if Align < 0 then Error_Msg_N ("negative alignment not allowed", Expr); elsif Align > Maximum_Alignment then Error_Msg_Uint_1 := UI_From_Int (Maximum_Alignment); Error_Msg_N ("?alignment exceeds ^ (maximum allowed for target)", N); else Set_Alignment_Clause (Ent, N); Set_Has_Alignment_Clause (Ent); end if; end if; end Alignment; --------------- -- Bit_Order -- --------------- -- Bit_Order attribute definition clause when Attribute_Bit_Order => Bit_Order : declare begin Note_Feature (New_Representation_Clauses, Sloc (N)); if not Is_Record_Type (Ent) then Error_Msg_N ("& definition requires record type", Nam); else Analyze (Expr); Resolve (Expr, RTE (RE_Bit_Order)); if Etype (Expr) = Any_Type then return; elsif not Is_Static_Expression (Expr) then Error_Msg_N ("& requires static expression", Expr); else if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then Error_Msg_N ("unsupported value for & attribute", Expr); end if; end if; end if; end Bit_Order; -------------------- -- Component_Size -- -------------------- -- Component_Size attribute definition clause when Attribute_Component_Size => Component_Size : declare Component_Size : constant Uint := Static_Integer (Expr); Btype : constant Entity_Id := Base_Type (Ent); begin Note_Feature (New_Representation_Clauses, Sloc (N)); if Has_Component_Size_Clause (Btype) then Error_Msg_Sloc := Sloc (Component_Size_Clause (Btype)); Error_Msg_N ("component size clase for& previously given#", Nam); elsif not Is_Array_Type (Ent) then Error_Msg_N ("component size requires array type", Nam); elsif Component_Size /= No_Uint then Check_Size (Expr, Component_Type (Btype), Component_Size); -- Note that Gigi is in charge of checking that the size we -- are assigning is acceptable, and will generate the error -- message if the size is inappropriate. Set_Component_Size_Clause (Btype, N); Set_Has_Component_Size_Clause (Btype); Set_Has_Non_Standard_Rep (Btype); end if; end Component_Size; ----------- -- Input -- ----------- when Attribute_Input => Input : declare Subp : Entity_Id; function Has_Good_Profile (Subp : Entity_Id) return Boolean; -- return true if the entity is a function with the good -- profile for the input attribute. function Has_Good_Profile (Subp : Entity_Id) return Boolean is F : Entity_Id; Ok : Boolean := False; begin if Ekind (Subp) = E_Function then F := First_Formal (Subp); if Present (F) and then No (Next_Formal (F)) then if Ekind (Etype (F)) = E_Anonymous_Access_Type and then Designated_Type (Etype (F)) = Class_Wide_Type (RTE (RE_Root_Stream_Type)) then Ok := Base_Type (Etype (Subp)) = Base_Type (Ent); end if; end if; end if; return Ok; end Has_Good_Profile; begin Note_Feature (New_Representation_Clauses, Sloc (N)); if not Is_Type (Ent) then Error_Msg_N ("local name must be a subtype", Nam); return; end if; Subp := Current_Entity (Expr); -- beginning of homonym chain. while Present (Subp) loop exit when Has_Good_Profile (Subp); Subp := Homonym (Subp); end loop; if Present (Subp) then Set_Entity (Expr, Subp); Set_Etype (Expr, Etype (Subp)); else Error_Msg_N ("incorrect expression for input attribute", Expr); return; end if; end Input; ------------------- -- Machine_Radix -- ------------------- -- Machine radix attribute definition clause when Attribute_Machine_Radix => Machine_Radix : declare Radix : constant Uint := Static_Integer (Expr); begin Note_Feature (New_Representation_Clauses, Sloc (N)); if not Is_Decimal_Fixed_Point_Type (Ent) then Error_Msg_N ("decimal fixed-point type expected for &", Nam); elsif Has_Machine_Radix_Clause (Ent) then Error_Msg_Sloc := Sloc (Alignment_Clause (Ent)); Error_Msg_N ("machine radix clause previously given#", N); elsif Radix /= No_Uint then Set_Has_Machine_Radix_Clause (Ent); Set_Has_Non_Standard_Rep (Ent); if Radix = 2 then null; elsif Radix = 10 then Set_Machine_Radix_10 (Ent); else Error_Msg_N ("machine radix value must be 2 or 10", Expr); end if; end if; end Machine_Radix; ------------ -- Output -- ------------ when Attribute_Output => Output : declare Subp : Entity_Id; function Has_Good_Profile (Subp : Entity_Id) return Boolean; -- return true if the entity is a procedure with the good -- profile for the output attribute. function Has_Good_Profile (Subp : Entity_Id) return Boolean is F : Entity_Id; Ok : Boolean := False; begin if Ekind (Subp) = E_Procedure then F := First_Formal (Subp); if Present (F) then if Ekind (Etype (F)) = E_Anonymous_Access_Type and then Designated_Type (Etype (F)) = Class_Wide_Type (RTE (RE_Root_Stream_Type)) then F := Next_Formal (F); Ok := Present (F) and then Parameter_Mode (F) = E_In_Parameter and then Base_Type (Etype (F)) = Base_Type (Ent) and then No (Next_Formal (F)); end if; end if; end if; return Ok; end Has_Good_Profile; begin Note_Feature (New_Representation_Clauses, Sloc (N)); if not Is_Type (Ent) then Error_Msg_N ("local name must be a subtype", Nam); return; end if; Subp := Current_Entity (Expr); -- beginning of homonym chain. while Present (Subp) loop exit when Has_Good_Profile (Subp); Subp := Homonym (Subp); end loop; if Present (Subp) then Set_Entity (Expr, Subp); Set_Etype (Expr, Etype (Subp)); else Error_Msg_N ("incorrect expression for read attribute", Expr); return; end if; end Output; ---------- -- Read -- ---------- when Attribute_Read => Read : declare Subp : Entity_Id; function Has_Good_Profile (Subp : Entity_Id) return Boolean; -- return true if the entity is a procedure with the good -- profile for the read attribute. function Has_Good_Profile (Subp : Entity_Id) return Boolean is F : Entity_Id; Ok : Boolean := False; begin if Ekind (Subp) = E_Procedure then F := First_Formal (Subp); if Present (F) then if Ekind (Etype (F)) = E_Anonymous_Access_Type and then Designated_Type (Etype (F)) = Class_Wide_Type (RTE (RE_Root_Stream_Type)) then F := Next_Formal (F); Ok := Present (F) and then Parameter_Mode (F) = E_Out_Parameter and then Base_Type (Etype (F)) = Base_Type (Ent) and then No (Next_Formal (F)); end if; end if; end if; return Ok; end Has_Good_Profile; begin Note_Feature (New_Representation_Clauses, Sloc (N)); if not Is_Type (Ent) then Error_Msg_N ("local name must be a subtype", Nam); return; end if; Subp := Current_Entity (Expr); -- beginning of homonym chain. while Present (Subp) loop exit when Has_Good_Profile (Subp); Subp := Homonym (Subp); end loop; if Present (Subp) then Set_Entity (Expr, Subp); Set_Etype (Expr, Etype (Subp)); else Error_Msg_N ("incorrect expression for read attribute", Expr); return; end if; end Read; ---------- -- Size -- ---------- -- Size attribute definition clause when Attribute_Size => Size : declare Size : constant Uint := Static_Integer (Expr); begin if Has_Size_Clause (Ent) then Error_Msg_N ("size already given for &", Nam); elsif not Is_Type (Ent) and then Ekind (Ent) /= E_Variable and then Ekind (Ent) /= E_Constant then Error_Msg_N ("size cannot be given for &", Nam); elsif Size /= No_Uint then -- Check size, note that Gigi is in charge of checking -- that the size of an array or record type is OK. Check_Size (Expr, Ent, Size); Set_Esize (Ent, Size); Set_Has_Size_Clause (Ent); end if; end Size; ----------- -- Small -- ----------- -- Small attribute definition clause when Attribute_Small => Small : declare Int_Type : Entity_Id; Implicit_Base : constant Entity_Id := Base_Type (Ent); Small : Ureal; Size_Min : Nat; begin Analyze (Expr); Resolve (Expr, Any_Real); if Etype (Expr) = Any_Type then return; elsif not Is_Static_Expression (Expr) then Error_Msg_N ("small requires static expression", Expr); return; else Small := Expr_Value_R (Expr); end if; if not Is_Ordinary_Fixed_Point_Type (Ent) then Error_Msg_N ("small requires an ordinary fixed point type", Nam); elsif Has_Small_Clause (Ent) then Error_Msg_N ("small already given for &", Nam); elsif Small < Ureal_Fine_Delta then Error_Msg_N ("small value must not be less than Fine_Delta", Nam); elsif Small > Delta_Value (Ent) then Error_Msg_N ("small value must not be greater then delta value", Nam); else Set_Small_Value (Ent, Small); Set_Small_Value (Implicit_Base, Small); Set_Has_Small_Clause (Ent); Set_Has_Small_Clause (Implicit_Base); Set_Has_Non_Standard_Rep (Ent); Size_Min := Minimum_Size (Implicit_Base); if Size_Min <= 8 then Set_Esize (Implicit_Base, Uint_8); elsif Size_Min <= 16 then Set_Esize (Implicit_Base, Uint_16); elsif Size_Min <= 32 then Set_Esize (Implicit_Base, Uint_32); elsif Size_Min <= 64 then Set_Esize (Implicit_Base, Uint_64); else Set_Esize (Implicit_Base, Uint_64); Error_Msg_N ("fixed type requires too many bits", Nam); end if; -- If previous size clause given, then simply check that -- it is consistent with the new small value given. if Has_Size_Clause (Ent) then if Esize (Ent) < Minimum_Size (Ent) then Error_Msg_N ("small value incompatible with previously given size", Nam); end if; -- If no previous size clause, then size of first subtype -- is set to the size of the implicit base type. else Set_Esize (Ent, Esize (Implicit_Base)); end if; end if; end Small; ------------------ -- Storage_Size -- ------------------ -- Storage_Size attribute definition clause when Attribute_Storage_Size => Storage_Size : declare Btype : constant Entity_Id := Base_Type (Ent); begin if Has_Storage_Size_Clause (Btype) then Error_Msg_N ("storage size already given for &", Nam); elsif not Is_Access_Type (Ent) and then Ekind (Ent) /= E_Task_Type then Error_Msg_N ("storage size cannot be given for &", Nam); else Analyze (Expr); Resolve (Expr, Any_Integer); if Is_Access_Type (Ent) and then Present (Associated_Storage_Pool (Ent)) then Error_Msg_N ("storage pool already given for &", Nam); return; else Set_Has_Storage_Size_Clause (Btype); end if; end if; end Storage_Size; ------------------ -- Storage_Pool -- ------------------ -- Storage_Pool attribute definition clause when Attribute_Storage_Pool => Storage_Pool : declare Pool : Entity_Id; begin Note_Feature (New_Representation_Clauses, Sloc (N)); Note_Feature (User_Defined_Storage_Pools, Sloc (N)); if Ekind (Ent) /= E_Access_Type and then Ekind (Ent) /= E_General_Access_Type then Error_Msg_N ( "storage pool can only be given for access types", Nam); return; elsif Has_Storage_Size_Clause (Ent) then Error_Msg_N ("storage size already given for &", Nam); return; elsif Present (Associated_Storage_Pool (Ent)) then Error_Msg_N ("storage pool already given for &", Nam); return; end if; Analyze (Expr); Resolve (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); if Is_Entity_Name (Expr) then Pool := Associated_Storage_Pool (Entity (Prefix (Expr))); if Present (Etype (Pool)) and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool) and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool) then Set_Associated_Storage_Pool (Ent, Pool); else Error_Msg_N ("Non sharable GNAT Pool", Expr); end if; else Error_Msg_N ("incorrect reference to a Storage Pool", Expr); return; end if; end Storage_Pool; ----------- -- Write -- ----------- -- Write attribute definition clause -- check for class-wide case will be performed later when Attribute_Write => Write : declare Subp : Entity_Id; function Has_Good_Profile (Subp : Entity_Id) return Boolean; -- return true if the entity is a procedure with the good -- profile for the write attribute. function Has_Good_Profile (Subp : Entity_Id) return Boolean is F : Entity_Id; Ok : Boolean := False; begin if Ekind (Subp) = E_Procedure then F := First_Formal (Subp); if Present (F) then if Ekind (Etype (F)) = E_Anonymous_Access_Type and then Designated_Type (Etype (F)) = Class_Wide_Type (RTE (RE_Root_Stream_Type)) then F := Next_Formal (F); Ok := Present (F) and then Parameter_Mode (F) = E_In_Parameter and then Base_Type (Etype (F)) = Base_Type (Ent) and then No (Next_Formal (F)); end if; end if; end if; return Ok; end Has_Good_Profile; begin Note_Feature (New_Representation_Clauses, Sloc (N)); if not Is_Type (Ent) then Error_Msg_N ("local name must be a subtype", Nam); return; end if; Subp := Current_Entity (Expr); -- beginning of homonym chain. while Present (Subp) loop exit when Has_Good_Profile (Subp); Subp := Homonym (Subp); end loop; if Present (Subp) then Set_Entity (Expr, Subp); Set_Etype (Expr, Etype (Subp)); else Error_Msg_N ("incorrect expression for write attribute", Expr); return; end if; end Write; -- All other attributes cannot be set when others => Error_Msg_N ("attribute& cannot be set with definition clause", N); end case; end Analyze_Attribute_Definition_Clause; ---------------------------- -- Analyze_Code_Statement -- ---------------------------- procedure Analyze_Code_Statement (N : Node_Id) is begin Unimplemented (N, "code statement"); end Analyze_Code_Statement; ----------------------------------------------- -- Analyze_Enumeration_Representation_Clause -- ----------------------------------------------- procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); 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 -- First some basic error checks Find_Type (Ident); Enumtype := Entity (Ident); if not Is_Enumeration_Type (Enumtype) then Error_Msg_NE ("enumeration type required, found}", Ident, Enumtype); return; end if; if not Is_First_Subtype (Enumtype) then Error_Msg_N ("cannot give enumeration rep clause for subtype", Ident); return; elsif Has_Enumeration_Rep_Clause (Enumtype) then Error_Msg_N ("duplicate enumeration rep clause ignored", N); return; elsif Already_Frozen (Enumtype, Ident) then return; elsif Root_Type (Enumtype) = Standard_Character or else Root_Type (Enumtype) = Standard_Wide_Character or else Root_Type (Enumtype) = Standard_Boolean then Error_Msg_N ("enumeration rep clause not allowed for this type", N); else Set_Has_Enumeration_Rep_Clause (Enumtype); Set_Has_Non_Standard_Rep (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) -- Badent signals that we found some incorrect entries processing -- the list. The final checks for completeness and ordering are -- skipped in this case. Elit := First_Literal (Enumtype); -- First the positional entries if any 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); 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); Expr := Next (Expr); Elit := 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 (Choice); 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 Error_Msg_N ("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); Val := Static_Integer (Expression (Assoc)); 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; Assoc := 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; end if; Elit := Next (Elit); end loop; end if; if Has_Size_Clause (Enumtype) then if Esize (Enumtype) >= Minimum_Size (Enumtype) then return; else Error_Msg_N ("previously given size is too small", N); end if; end if; -- If we don't have a given size, or if the size given was too -- small, then compute an appropriate size for the values given. Determine_Enum_Representation (Enumtype); 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; Mod_Val : Uint; CC : Node_Id; Posit : Uint; Fbit : Uint; Lbit : Uint; Adjust : Uint; Hbit : Uint := Uint_0; Comp : Entity_Id; begin -- First some basic error checks Find_Type (Ident); Rectype := Entity (Ident); if not Is_Record_Type (Rectype) then Error_Msg_NE ("record type required, found}", Ident, Rectype); return; end if; if not Is_First_Subtype (Rectype) then Error_Msg_N ("cannot give record rep clause for subtype", Ident); return; elsif Has_Record_Rep_Clause (Rectype) then Error_Msg_N ("duplicate record rep clause ignored", N); return; elsif Already_Frozen (Rectype, Ident) then return; else Set_Has_Record_Rep_Clause (Rectype); Set_Has_Non_Standard_Rep (Rectype); Set_Has_Specified_Layout (Rectype); end if; if Present (Mod_Clause (N)) then Mod_Val := Static_Integer (Expression (Mod_Clause (N))); end if; -- Clear any existing component clauses for the type (this happens -- with derived types, where we are now overriding the original) Comp := First_Entity (Rectype); while Present (Comp) loop if Ekind (Comp) = E_Component or else Ekind (Comp) = E_Discriminant then Set_Component_Clause (Comp, Empty); end if; Comp := Next_Entity (Comp); end loop; -- Process the component clauses CC := First (Component_Clauses (N)); while Present (CC) loop 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)); -- Values look OK, so find the corresponding record component else Comp := First_Entity (Rectype); while Present (Comp) loop exit when Chars (Comp) = Chars (Component_Name (CC)); Comp := Next_Entity (Comp); end loop; if No (Comp) then Error_Msg_N ("component clause is for non-existent field", N); elsif Present (Component_Clause (Comp)) then Error_Msg_Sloc := Sloc (Component_Clause (Comp)); Error_Msg_N ("component clause previously given#", CC); else -- Update Fbit and Lbit to the actual bit number. Fbit := Fbit + UI_From_Int (System_Storage_Unit) * Posit; Lbit := Lbit + UI_From_Int (System_Storage_Unit) * Posit; 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_First_Bit (Comp, Fbit); Set_Esize (Comp, 1 + (Lbit - Fbit)); if Hbit < Lbit then Hbit := Lbit; end if; Check_Size (Component_Name (CC), Etype (Comp), Esize (Comp)); if Esize (Comp) < 0 then Error_Msg_N ("component size is negative", CC); end if; end if; end if; end if; end if; CC := 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. Overlap_Check : 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 being checked begin C1_Ent := First_Entity (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; Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); -- Loop through component lists that need checking. We check the -- current component list and all lists in variants above us. Component_List_Loop : loop -- Loop through items in one component list or in the -- discriminant specification list. if Nkind (Clist) = N_Full_Type_Declaration then if Present (Discriminant_Specifications (Clist)) then Citem := First (Discriminant_Specifications (Clist)); else Citem := Empty; end if; else Citem := First (Component_Items (Clist)); end if; Component_Loop : while Present (Citem) loop if Nkind (Citem) = N_Component_Declaration or else Nkind (Citem) = N_Discriminant_Specification then C2_Ent := Defining_Identifier (Citem); -- Exit loop if we hit current component (saves a factor -- of 2 comparisons, since we only compare one direction) exit Component_Loop when C1_Ent = C2_Ent; -- Do the comparison if Present (Component_Clause (C1_Ent)) and then Present (Component_Clause (C2_Ent)) then declare S1 : constant Uint := Component_First_Bit (C1_Ent); S2 : constant Uint := Component_First_Bit (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 if; Citem := Next (Citem); end loop Component_Loop; -- 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 we have the parent of the component list is the -- record definition, and its parent is the full type -- declaration which contains the discriminant specifications. 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>> C1_Ent := Next_Entity (C1_Ent); end loop Main_Component_Loop; end Overlap_Check; Set_Esize (Rectype, Hbit + 1); end Analyze_Record_Representation_Clause; ---------------- -- Check_Size -- ---------------- procedure Check_Size (N : Node_Id; T : Entity_Id; Siz : Uint) is UT : constant Entity_Id := Underlying_Type (T); M : Uint; begin -- Immediate return if size is same as standard size or if composite -- item with no size available (i.e. none was given explicitly) or -- generic type, or type with previous errors. if No (UT) or else Esize (UT) = 0 or else Siz = Esize (UT) then return; -- If type has record representation clause, the saved size if the -- mimimum size. elsif Is_Record_Type (UT) and then Has_Record_Rep_Clause (UT) then if Siz < Esize (UT) then Error_Msg_Uint_1 := Esize (UT); Error_Msg_NE ("size for& too small, minimum allowed is ^", N, T); end if; -- Types for which the only permitted size is the standard size elsif Is_Floating_Point_Type (UT) or else Is_Access_Type (UT) or else Is_Composite_Type (UT) then Error_Msg_Uint_1 := Esize (UT); Error_Msg_NE ("incorrect size for&, must be exactly ^", N, T); -- For remaining types, maximum size is Long_Long_Integer size elsif Siz > Standard_Long_Long_Integer_Size then Error_Msg_Uint_1 := UI_From_Int (Standard_Long_Long_Integer_Size); Error_Msg_NE ("size for& too large, maximum allowed is ^", N, T); -- Cases for which a minimum check is required else M := UI_From_Int (Minimum_Size (UT)); if Siz < M then Error_Msg_Uint_1 := M; Error_Msg_NE ("size for& too small, minimum allowed is ^", N, T); end if; end if; end Check_Size; ------------------ -- Minimum_Size -- ------------------ function Minimum_Size (T : Entity_Id) return Nat is Lo, Hi : Uint; LoR, HiR : Ureal; B : Uint; S : Nat; function Get_Enum_Rep (N : Node_Id) return Uint; -- N is an enumeration literal reference. This function returns -- the corresponding enumeration representation, dealing with the -- special case of Standard.Character or Standard.Wide_Character -- where no entity is present (in which case the representation -- is simply that of the character literal itself). function Get_Enum_Rep (N : Node_Id) return Uint is begin if Present (Entity (N)) then return Enumeration_Rep (Entity (N)); else return UI_From_Int (Int (Char_Literal_Value (N))); end if; end Get_Enum_Rep; -- Start of processing for Minimum_Size begin -- Enumeration types if Is_Enumeration_Type (T) then if Is_Entity_Name (Type_Low_Bound (T)) then Lo := Get_Enum_Rep (Type_Low_Bound (T)); else Lo := Get_Enum_Rep (Type_Low_Bound (Base_Type (T))); end if; if Is_Entity_Name (Type_High_Bound (T)) then Hi := Get_Enum_Rep (Type_High_Bound (T)); else Hi := Get_Enum_Rep (Type_High_Bound (Base_Type (T))); end if; -- Integer types elsif Is_Integer_Type (T) then if Is_Static_Expression (Type_Low_Bound (T)) then Lo := Expr_Value (Type_Low_Bound (T)); else Lo := Expr_Value (Type_Low_Bound (Base_Type (T))); end if; if Is_Static_Expression (Type_High_Bound (T)) then Hi := Expr_Value (Type_High_Bound (T)); else Hi := Expr_Value (Type_High_Bound (Base_Type (T))); end if; -- 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. elsif Is_Fixed_Point_Type (T) then if Is_Static_Expression (Type_Low_Bound (T)) then LoR := Expr_Value_R (Type_Low_Bound (T)); else LoR := Expr_Value_R (Type_Low_Bound (Base_Type (T))); end if; if Is_Static_Expression (Type_High_Bound (T)) then HiR := Expr_Value_R (Type_High_Bound (T)); else HiR := Expr_Value_R (Type_High_Bound (Base_Type (T))); end if; Lo := UR_To_Uint (LoR / Small_Value (T)); Hi := UR_To_Uint (HiR / Small_Value (T)); -- No other types allowed else pragma Assert (False); null; end if; -- Signed case if Lo < 0 then S := 1; B := Uint_1; while Lo < -B or else Hi >= B loop S := S + 1; B := B + B; end loop; -- Unsigned case else S := 0; B := Uint_1; while Hi > B loop S := S + 1; B := B + B; end loop; end if; return S; end Minimum_Size; -------------------------------------- -- Validate_Unchecked_Conversion -- -------------------------------------- procedure Validate_Unchecked_Conversion (N : Node_Id; Act_Unit : Entity_Id) is Source : Entity_Id; Target : Entity_Id; procedure No_Unconstrained_Type (T : Node_Id); -- Issue error if type T is an unconstrained type procedure No_Unconstrained_Type (T : Node_Id) is begin if Is_Indefinite_Subtype (T) then Error_Msg_NE ("unconstrained } not allowed in unchecked conversion", N, T); end if; end No_Unconstrained_Type; -- Start of processing for Validate_Unchecked_Conversion begin -- 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 := Etype (First_Formal (Act_Unit)); if Is_Private_Type (Source) and then Present (Underlying_Type (Source)) then Source := Underlying_Type (Source); end if; Target := Etype (Act_Unit); if Is_Private_Type (Target) and then Present (Underlying_Type (Target)) then Target := Underlying_Type (Target); end if; No_Unconstrained_Type (Source); No_Unconstrained_Type (Target); if Esize (Source) /= 0 and then Esize (Target) /= 0 and then Esize (Source) /= Esize (Target) then Error_Msg_N ("types for unchecked conversion have different sizes", N); end if; end Validate_Unchecked_Conversion; end Sem_Ch13;