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 / exp_attr.adb < prev next >

Wrap

Text File | 1996-09-28 | 78KB | 2,307 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ A T T R -- -- -- -- B o d y -- -- -- -- $Revision: 1.119 $ -- -- -- -- 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 Exp_Ch9; use Exp_Ch9; with Exp_TSS; use Exp_TSS; with Exp_Util; use Exp_Util; with Itypes; use Itypes; with Namet; use Namet; with Nmake; use Nmake; with Nlists; use Nlists; with Opt; use Opt; with Output; use Output; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; with Uname; use Uname; with Urealp; use Urealp; package body Exp_Attr is ----------------------- -- Local Subprograms -- ----------------------- procedure Expand_Fpt_Attribute (N : Node_Id; Args : List_Id); -- This procedure expands a call to a floating-point attribute function. -- N is the attribute reference node, and Args is a list of arguments to -- be passed to the function call. procedure Expand_Fpt_Attribute_R (N : Node_Id); -- This procedure expands a call to a floating-point attribute function -- that takes a single floating-point argument. procedure Expand_Fpt_Attribute_RI (N : Node_Id); -- This procedure expands a call to a floating-point attribute function -- that takes one floating-point argument and one integer argument. procedure Expand_Fpt_Attribute_RR (N : Node_Id); -- This procedure expands a call to a floating-point attribute function -- that takes two floating-point arguments. procedure Expand_Pred_Succ (N : Node_Id); -- Handles expansion of Pred or Succ attributes for case of non-real -- operand with overflow checking required. function Get_Index_Subtype (N : Node_Id) return Entity_Id; -- Used for Last, Last, and Length, when the prefix is an array type, -- Obtains the corresponding index subtype. -------------------------- -- Expand_Fpt_Attribute -- -------------------------- procedure Expand_Fpt_Attribute (N : Node_Id; Args : List_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Rtp : constant Entity_Id := Root_Type (Typ); Pkg : RE_Id; Fnm : Node_Id; begin -- The function name is the selected component Fat_xxx.yyy where xxx -- is the floating-point root type, and yyy is the attribute name -- Note: it would be more usual to have separate RE entries for each -- of the entities in the Fat packages, but first they have identical -- names (so we would have to have lots of renaming declarations to -- meet the normal RE rule of separate names for all runtime entities), -- and second there would be an awful lot of them! if Rtp = Standard_Short_Float then Pkg := RE_Fat_Short_Float; elsif Rtp = Standard_Float then Pkg := RE_Fat_Float; elsif Rtp = Standard_Long_Float then Pkg := RE_Fat_Long_Float; else Pkg := RE_Fat_Long_Long_Float; end if; Fnm := Make_Selected_Component (Loc, Prefix => New_Reference_To (RTE (Pkg), Loc), Selector_Name => Make_Identifier (Loc, Attribute_Name (N))); -- The generated call is given the provided set of parameters, and then -- wrapped in a conversion which converts the result to the target type Rewrite_Substitute_Tree (N, Unchecked_Convert_To (Etype (N), Make_Function_Call (Loc, Name => Fnm, Parameter_Associations => Args))); Analyze (N); Resolve (N, Typ); end Expand_Fpt_Attribute; ---------------------------- -- Expand_Fpt_Attribute_R -- ---------------------------- -- The single argument is converted to its root type to call the -- appropriate runtime function, with the actual call being built -- by Expand_Fpt_Attribute procedure Expand_Fpt_Attribute_R (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Rtp : constant Entity_Id := Root_Type (Etype (N)); E1 : constant Node_Id := First (Expressions (N)); begin Expand_Fpt_Attribute (N, New_List ( Unchecked_Convert_To (Rtp, Relocate_Node (E1)))); end Expand_Fpt_Attribute_R; ----------------------------- -- Expand_Fpt_Attribute_RI -- ----------------------------- -- The first argument is converted to its root type and the second -- argument is converted to standard long long integer to call the -- appropriate runtime function, with the actual call being built -- by Expand_Fpt_Attribute procedure Expand_Fpt_Attribute_RI (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Rtp : constant Entity_Id := Root_Type (Etype (N)); E1 : constant Node_Id := First (Expressions (N)); E2 : constant Node_Id := Next (E1); begin Expand_Fpt_Attribute (N, New_List ( Unchecked_Convert_To (Rtp, Relocate_Node (E1)), Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2)))); end Expand_Fpt_Attribute_RI; ----------------------------- -- Expand_Fpt_Attribute_RR -- ----------------------------- -- The two arguments is converted to their root types to call the -- appropriate runtime function, with the actual call being built -- by Expand_Fpt_Attribute procedure Expand_Fpt_Attribute_RR (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Rtp : constant Entity_Id := Root_Type (Etype (N)); E1 : constant Node_Id := First (Expressions (N)); E2 : constant Node_Id := Next (E1); begin Expand_Fpt_Attribute (N, New_List ( Unchecked_Convert_To (Rtp, Relocate_Node (E1)), Unchecked_Convert_To (Rtp, Relocate_Node (E2)))); end Expand_Fpt_Attribute_RR; ---------------------------------- -- Expand_N_Attribute_Reference -- ---------------------------------- procedure Expand_N_Attribute_Reference (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Pref : constant Node_Id := Prefix (N); Exprs : constant List_Id := Expressions (N); Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); begin case Id is -------------- -- Adjacent -- -------------- -- Transforms 'Adjacent into a call to the floating-point attribute -- function Adjacent in Fat_xxx (where xxx is the root type) when Attribute_Adjacent => Expand_Fpt_Attribute_RR (N); ------------- -- Address -- ------------- -- If the prefix is a task or a task type, the useful address is that -- of the procedure for the task body, i.e. the actual program unit. -- We replace the orignal entity with that of the procedure. when Attribute_Address => Address : declare Task_Proc : Entity_Id; begin if Is_Task_Type (Etype (Pref)) then Task_Proc := Next_Entity (Root_Type (Etype (Pref))); while Present (Task_Proc) loop exit when Ekind (Task_Proc) = E_Procedure and then Etype (First_Formal (Task_Proc)) = Corresponding_Record_Type (Etype (Pref)); Task_Proc := Next_Entity (Task_Proc); end loop; if Present (Task_Proc) then Set_Entity (Pref, Task_Proc); Set_Etype (Pref, Etype (Task_Proc)); end if; end if; end Address; ------------------ -- Body_Version -- ------------------ -- A reference to x'Body_Version or x'Version is expanded to -- [xnn : Unsigned; -- pragma Import (C, xnn, "uuuuT"); -- Get_Version_String (xnn)] -- where uuuu is the unit name (with dots replaced by double underscore -- and T is B for the cases of Body_Version, or Version applied to a -- subprogram acting as its own spec, and S for Version applied to a -- subprogram spec or package. This sequence of code references the -- the unsigned constant created in the main program by the binder. when Attribute_Body_Version | Attribute_Version => Version : declare E : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('X')); Pent : constant Entity_Id := Entity (Pref); S : String_Id; Spec : Node_Id; begin -- Build required string constant Get_Name_String (Get_Unit_Name (Pent)); Start_String; for J in 1 .. Name_Len - 2 loop if Name_Buffer (J) = '.' then Store_String_Chars ("__"); else Store_String_Char (Get_Char_Code (Name_Buffer (J))); end if; end loop; if Id = Attribute_Body_Version or else (Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification and then Nkind (Parent (Declaration_Node (Pent))) = N_Subprogram_Body and then Acts_As_Spec (Parent (Declaration_Node (Pent)))) then Store_String_Chars ("B"); else Store_String_Chars ("S"); end if; S := End_String; -- Now we can do the replacement Rewrite_Substitute_Tree (N, Make_Expression_Actions (Loc, Actions => New_List ( Make_Object_Declaration (Loc, Defining_Identifier => E, Object_Definition => New_Occurrence_Of (RTE (RE_Unsigned), Loc)), Make_Pragma (Loc, Chars => Name_Import, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Name_C)), Make_Pragma_Argument_Association (Loc, Expression => New_Occurrence_Of (E, Loc)), Make_Pragma_Argument_Association (Loc, Expression => Make_String_Literal (Loc, S))))), Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Get_Version_String), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (E, Loc))))); Analyze (N); Resolve (N, RTE (RE_Version_String)); end Version; ------------- -- Ceiling -- ------------- -- Transforms 'Ceiling into a call to the floating-point attribute -- function Ceiling in Fat_xxx (where xxx is the root type) when Attribute_Ceiling => Expand_Fpt_Attribute_R (N); -------------- -- Callable -- -------------- -- Transforms 'Callable attribute into a call to the Callable function. when Attribute_Callable => Callable : begin Rewrite_Substitute_Tree (N, Build_Call_With_Task (Pref, RTE (RE_Callable))); Analyze (N); Resolve (N, Standard_Boolean); end Callable; ------------- -- Compose -- ------------- -- Transforms 'Compose into a call to the floating-point attribute -- function Compose in Fat_xxx (where xxx is the root type) -- Note: we strictly should have special code here to deal with the -- case of absurdly negative arguments (less than Integer'First) -- which will return a (signed) zero value, but it hardly seems -- worth the effort. Absurdly large positive arguments will raise -- constraint error which is fine. when Attribute_Compose => Expand_Fpt_Attribute_RI (N); ----------------- -- Constrained -- ----------------- -- A very temporary implementation! when Attribute_Constrained => if Is_Entity_Name (Pref) then Constrained : declare Ent : constant Entity_Id := Entity (Pref); Kind : constant Entity_Kind := Ekind (Ent); Res : Boolean; begin -- Always return False for the obsolescent case. This is a -- temporary kludge to be fixed later ??? if Is_Private_Type (Ent) then Res := False; -- If the prefix is not a variable, then definitely true elsif not Is_Variable (Pref) then Res := True; -- For a variable other than a procedure formal, we can -- determine the result at compile time accurately. elsif Kind not in Formal_Kind then Res := Is_Constrained (Etype (Ent)); -- For a procedure parameter, always return True, this is -- a temporary kludge to be fixed later ??? else Res := True; end if; if Res then Rewrite_Substitute_Tree (N, New_Reference_To (Standard_True, Loc)); else Rewrite_Substitute_Tree (N, New_Reference_To (Standard_False, Loc)); end if; Analyze (N); Resolve (N, Standard_Boolean); end Constrained; else if not Is_Variable (Pref) or else Nkind (Pref) = N_Explicit_Dereference or else Is_Constrained (Etype (Pref)) then Rewrite_Substitute_Tree (N, New_Reference_To (Standard_True, Loc)); else Rewrite_Substitute_Tree (N, New_Reference_To (Standard_False, Loc)); end if; Analyze (N); Resolve (N, Standard_Boolean); end if; --------------- -- Copy_Sign -- --------------- -- Transforms 'Copy_Sign into a call to the floating-point attribute -- function Copy_Sign in Fat_xxx (where xxx is the root type) when Attribute_Copy_Sign => Expand_Fpt_Attribute_RR (N); ----------- -- Count -- ----------- -- Transforms 'Count attribute into a call to the Count function when Attribute_Count => Count : declare Entnam : Node_Id; Index : Node_Id; Call : Node_Id; Conctyp : Entity_Id; begin -- This needs comments ??? if Nkind (Pref) = N_Indexed_Component then Entnam := Prefix (Pref); Index := First (Expressions (Pref)); else Entnam := Pref; Index := Empty; end if; -- Find the concurrent type in which this attribute is referenced -- (there had better be one). Conctyp := Current_Scope; while not Is_Concurrent_Type (Conctyp) loop Conctyp := Scope (Conctyp); end loop; if Is_Protected_Type (Conctyp) then Call := Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Protected_Count), Loc), Parameter_Associations => New_List ( New_Reference_To ( Object_Ref (Corresponding_Body (Parent (Conctyp))), Loc), Entry_Index_Expression (Loc, Entity (Entnam), Index, Scope (Entity (Entnam))))); else Call := Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Task_Count), Loc), Parameter_Associations => New_List ( Entry_Index_Expression (Loc, Entity (Entnam), Index, Scope (Entity (Entnam))))); end if; -- The call returns type Natural but the context is universal integer -- so any integer type is allowed. The attribute was already resolved -- so its Etype is the required result type. If the base type of the -- context type is other than Standard.Integer we put in a conversion -- to the required type. This can be a normal typed conversion since -- both input and output types of the conversion are integer types if Base_Type (Typ) /= Standard_Integer then Rewrite_Substitute_Tree (N, Convert_To (Typ, Call)); else Rewrite_Substitute_Tree (N, Call); end if; Analyze (N); Resolve (N, Typ); end Count; -------------- -- Enum_Rep -- -------------- -- X'Enum_Rep (Y) expands to -- target-type (Y) -- This is simply a direct conversion from the enumeration type -- to the target integer type, which is treated by Gigi as a normal -- integer conversion, treating the enumeration type as an integer, -- which is exactly what we want! We set Conversion_OK to make sure -- that the analyzer does not complain about what otherwise would be -- a clearly illegal conversion. when Attribute_Enum_Rep => Enum_Rep : begin Rewrite_Substitute_Tree (N, Convert_To (Typ, Relocate_Node (First (Exprs)))); Set_Etype (N, Typ); Set_Conversion_OK (N); Analyze (N); Resolve (N, Typ); end Enum_Rep; -------------- -- Exponent -- -------------- -- Transforms 'Exponent into a call to the floating-point attribute -- function Exponent in Fat_xxx (where xxx is the root type) when Attribute_Exponent => Expand_Fpt_Attribute_R (N); ----------- -- First -- ----------- when Attribute_First => -- If the prefix type is a packed array type which already has a -- Packed_Array_Type representation defined, then replace this -- attribute with a direct reference to 'First of the appropriate -- index subtype (since otherwise Gigi will try to give us the -- value of 'First for this implementation type). if Is_Array_Type (Etype (Pref)) and then Present (Packed_Array_Type (Etype (Pref))) then Rewrite_Substitute_Tree (N, Make_Attribute_Reference (Loc, Attribute_Name => Name_First, Prefix => New_Reference_To (Get_Index_Subtype (N), Loc))); Analyze (N); Resolve (N, Typ); end if; --------------- -- First_Bit -- --------------- -- We compute this if a component clause was present, otherwise -- we leave the computation up to Gigi, since we don't know what -- layout will be chosen. when Attribute_First_Bit => First_Bit : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin if Present (Component_Clause (CE)) then Rewrite_Substitute_Tree (N, Make_Integer_Literal (Loc, Component_First_Bit (CE) mod System_Storage_Unit)); end if; Analyze (N); Resolve (N, Typ); end First_Bit; ----------------- -- Fixed_Value -- ----------------- -- fixtype'Fixed_Value (integer-value) -- is transformed into -- fixtype(integer-value) -- where the conversion has Conversion_OK set, so that it will be -- treated as a direct numeric conversion by Gigi, which is what we -- want (i.e. it will not be further modified by analysis). when Attribute_Fixed_Value => Fixed_Value : begin Rewrite_Substitute_Tree (N, Convert_To (Base_Type (Entity (Pref)), Relocate_Node (First (Exprs)))); Set_Etype (N, Typ); Set_Conversion_OK (N); Analyze (N); Resolve (N, Typ); end Fixed_Value; ----------- -- Floor -- ----------- -- Transforms 'Floor into a call to the floating-point attribute -- function Floor in Fat_xxx (where xxx is the root type) when Attribute_Floor => Expand_Fpt_Attribute_R (N); ---------- -- Fore -- ---------- -- For the fixed-point type Typ: -- Typ'Fore -- expands into -- Result_Type (System.Fore (Long_Long_Float (Type'First)), -- Long_Long_Float (Type'Last)) -- Note that we know that the type is a non-static subtype, or Fore -- would have itself been computed dynamically in Eval_Attribute. when Attribute_Fore => Fore : declare Ptyp : constant Entity_Id := Etype (Pref); begin Rewrite_Substitute_Tree (N, Convert_To (Typ, Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Fore), Loc), Parameter_Associations => New_List ( Convert_To (Standard_Long_Long_Float, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_First)), Convert_To (Standard_Long_Long_Float, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Last)))))); Analyze (N); Resolve (N, Typ); end Fore; -------------- -- Fraction -- -------------- -- Transforms 'Fraction into a call to the floating-point attribute -- function Fraction in Fat_xxx (where xxx is the root type) when Attribute_Fraction => Expand_Fpt_Attribute_R (N); ----------- -- Image -- ----------- -- For types other than user defined enumeration types, -- typ'Image (Val) expands into: -- Image_xx (tp (Val) [, pm]) -- The name xx and type conversion tp (Val) (called tv below) depend on -- the root type of Val. The argument pm is an extra type dependent -- parameter only used in some cases as follows: -- For types whose root type is Character -- xx = Character -- tv = Character (Val) -- For types whose root type is Boolean -- xx = Boolean -- tv = Boolean (Val) -- For signed integer types with size <= Integer'Size -- xx = Integer -- tv = Integer (Val) -- For other signed integer types -- xx = Long_Long_Integer -- tv = Long_Long_Integer (Val) -- For modular types with modulus <= System.Unsigned_Types.Unsigned -- xx = Unsigned -- tv = System.Unsigned_Types.Unsigned (Val) -- For other modular integer types -- xx = Long_Long_Unsigned -- tv = System.Unsigned_Types.Long_Long_Unsigned (Val) -- For types whose root type is Wide_Character -- xx = Wide_Character -- tv = Wide_Character (Val) -- pm = Wide_Character_Encoding_Method -- For floating-point types -- xx = Floating_Point -- tv = Long_Long_Float (Val) -- pm = typ'Digits -- For ordinary fixed-point types -- xx = Ordinary_Fixed_Point -- tv = Long_Long_Float (Val) -- pm = typ'Aft -- For decimal fixed-point types with size = Integer'Size -- xx = Decimal -- tv = Integer (Val) -- pm = typ'Scale -- For decimal fixed-point types with size > Integer'Size -- xx = Long_Long_Decimal -- tv = Long_Long_Integer (Val) -- pm = typ'Scale -- For enumeration types other than those derived from types Boolean, -- Character, and Wide_Character in Standard, typ'Image (X) expands to: -- Table (Enum'Pos (X)).all -- where table is the special table declared in the front end and -- constructed by special code in Gigi. when Attribute_Image => Image : declare Ptyp : constant Entity_Id := Entity (Pref); Rtyp : constant Entity_Id := Root_Type (Ptyp); Expr : constant Node_Id := Relocate_Node (First (Exprs)); Imid : RE_Id; Tent : Entity_Id; Arglist : List_Id; Snn : Entity_Id; begin if Rtyp = Standard_Boolean then Imid := RE_Image_Boolean; Tent := Rtyp; elsif Rtyp = Standard_Character then Imid := RE_Image_Character; Tent := Rtyp; elsif Rtyp = Standard_Wide_Character then Imid := RE_Image_Wide_Character; Tent := Rtyp; elsif Is_Signed_Integer_Type (Rtyp) then if Esize (Rtyp) <= Esize (Standard_Integer) then Imid := RE_Image_Integer; Tent := Standard_Integer; else Imid := RE_Image_Long_Long_Integer; Tent := Standard_Long_Long_Integer; end if; elsif Is_Modular_Integer_Type (Rtyp) then if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then Imid := RE_Image_Unsigned; Tent := RTE (RE_Unsigned); else Imid := RE_Image_Long_Long_Unsigned; Tent := RTE (RE_Long_Long_Unsigned); end if; elsif Is_Decimal_Fixed_Point_Type (Rtyp) then if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then Imid := RE_Image_Decimal; Tent := Standard_Integer; else Imid := RE_Image_Long_Long_Decimal; Tent := Standard_Long_Long_Integer; end if; elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then Imid := RE_Image_Ordinary_Fixed_Point; Tent := Standard_Long_Long_Float; elsif Is_Floating_Point_Type (Rtyp) then Imid := RE_Image_Floating_Point; Tent := Standard_Long_Long_Float; -- Only other possibility is user defined enumeration type else Rewrite_Substitute_Tree (N, Make_Explicit_Dereference (Loc, Prefix => Make_Indexed_Component (Loc, Prefix => New_Reference_To (Lit_Name_Table (Entity (Pref)), Loc), Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => Pref, Attribute_Name => Name_Pos, Expressions => New_List (Expr)))))); Analyze (N); Resolve (N, Standard_String); return; end if; -- If we fall through, we have one of the cases that is handled by -- calling one of the System.Img_xx routines. Arglist := New_List (Convert_To (Tent, Relocate_Node (Expr))); -- For floating-point types, append Digits argument if Is_Floating_Point_Type (Rtyp) then Append_To (Arglist, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Digits)); -- For ordinary fixed-point types, append Aft parameter elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then Append_To (Arglist, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Aft)); -- For wide character, append encoding method elsif Rtyp = Standard_Wide_Character then Append_To (Arglist, Make_Integer_Literal (Loc, Intval => UI_From_Int (Int (Wide_Character_Encoding_Method)))); -- For decimal, append Scale elsif Is_Decimal_Fixed_Point_Type (Rtyp) then Append_To (Arglist, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Scale)); end if; Rewrite_Substitute_Tree (N, Make_Function_Call (Loc, Name => New_Reference_To (RTE (Imid), Loc), Parameter_Associations => Arglist)); Analyze (N); Resolve (N, Standard_String); end Image; --------- -- Img -- --------- -- X'Img is expanded to typ'Image (X), where typ is the type of X when Attribute_Img => Img : begin Rewrite_Substitute_Tree (N, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Etype (Pref), Loc), Attribute_Name => Name_Image, Expressions => New_List (Relocate_Node (Pref)))); Analyze (N); Resolve (N, Standard_String); end Img; ------------------- -- Integer_Value -- ------------------- -- inttype'Fixed_Value (fixed-value) -- is transformed into -- inttype(integer-value)) -- where the conversion has Conversion_OK set, so that it will be -- treated as a direct numeric conversion by Gigi, which is what we -- want (i.e. it will not be further modified by analysis). when Attribute_Integer_Value => Integer_Value : begin Rewrite_Substitute_Tree (N, Convert_To (Base_Type (Entity (Pref)), Relocate_Node (First (Exprs)))); Set_Etype (N, Typ); Set_Conversion_OK (N); Analyze (N); Resolve (N, Typ); end Integer_Value; ---------- -- Last -- ---------- when Attribute_Last => -- If the prefix type is a packed array type which already has a -- Packed_Array_Type representation defined, then replace this -- attribute with a direct reference to 'Last of the appropriate -- index subtype (since otherwise Gigi will try to give us the -- value of 'First for this implementation type). if Is_Array_Type (Etype (Pref)) and then Present (Packed_Array_Type (Etype (Pref))) then Rewrite_Substitute_Tree (N, Make_Attribute_Reference (Loc, Attribute_Name => Name_Last, Prefix => New_Reference_To (Get_Index_Subtype (N), Loc))); Analyze (N); Resolve (N, Typ); end if; -------------- -- Last_Bit -- -------------- when Attribute_Last_Bit => Last_Bit : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin if Present (Component_Clause (CE)) then Rewrite_Substitute_Tree (N, Make_Integer_Literal (Loc, Intval => (Component_First_Bit (CE) mod System_Storage_Unit) + Esize (CE) - 1)); end if; Analyze (N); Resolve (N, Typ); end Last_Bit; ------------------ -- Leading_Part -- ------------------ -- Transforms 'Leading_Part into a call to the floating-point attribute -- function Leading_Part in Fat_xxx (where xxx is the root type) -- Note: strictly, we should have special case code to deal with -- absurdly large positive arguments (greater than Integer'Last), -- which result in returning the first argument unchanged, but it -- hardly seems worth the effort. We raise constraint error for -- absurdly negative arguments which is fine. when Attribute_Leading_Part => Expand_Fpt_Attribute_RI (N); ------------ -- Length -- ------------ when Attribute_Length => -- If the prefix type is a packed array type which already has a -- Packed_Array_Type representation defined, then replace this -- attribute with a direct reference to 'Range_Length of the -- appropriate index subtype (since otherwise Gigi will try to -- give us the value of 'First for this implementation type). if Is_Array_Type (Etype (Pref)) and then Present (Packed_Array_Type (Etype (Pref))) then Rewrite_Substitute_Tree (N, Make_Attribute_Reference (Loc, Attribute_Name => Name_Range_Length, Prefix => New_Reference_To (Get_Index_Subtype (N), Loc))); Analyze (N); Resolve (N, Typ); end if; ------------- -- Machine -- ------------- -- Transforms 'Machine into a call to the floating-point attribute -- function Machine in Fat_xxx (where xxx is the root type) when Attribute_Machine => Expand_Fpt_Attribute_R (N); ----------- -- Model -- ----------- -- Transforms 'Model into a call to the floating-point attribute -- function Model in Fat_xxx (where xxx is the root type) when Attribute_Model => Expand_Fpt_Attribute_R (N); --------- -- Pos -- --------- -- For enumeration types with a standard representation, and for all -- other types, Pos is handled by Gigi. For enumeration types with -- a non-standard representation we call the _Rep_To_Pos function -- created when the type was frozen. when Attribute_Pos => Pos : declare Etyp : constant Entity_Id := Base_Type (Entity (Pref)); begin if Is_Enumeration_Type (Etyp) and then Present (Enum_Pos_To_Rep (Etyp)) then Rewrite_Substitute_Tree (N, Convert_To (Typ, Make_Function_Call (Loc, Name => New_Reference_To (TSS (Etyp, Name_uRep_To_Pos), Loc), Parameter_Associations => New_List ( Relocate_Node (First (Exprs)))))); Analyze (N); Resolve (N, Typ); end if; end Pos; -------------- -- Position -- -------------- -- We compute this if a component clause was present, otherwise -- we leave the computation up to Gigi, since we don't know what -- layout will be chosen. when Attribute_Position => Position : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin if Present (Component_Clause (CE)) then Rewrite_Substitute_Tree (N, Make_Integer_Literal (Loc, Intval => Component_First_Bit (CE) / System_Storage_Unit)); Analyze (N); Resolve (N, Typ); end if; end Position; ---------- -- Pred -- ---------- -- 1. Deal with enumeration types with holes -- 2. For floating-point, generate call to attribute function -- 3. For other cases, deal with constraint checking when Attribute_Pred => Pred : declare Ptyp : constant Entity_Id := Base_Type (Etype (Pref)); begin -- For enumeration types with non-standard representations, we -- expand typ'Pred (x) into -- Pos_To_Rep (Rep_To_Pos (x) - 1) if Is_Enumeration_Type (Ptyp) and then Present (Enum_Pos_To_Rep (Ptyp)) then Rewrite_Substitute_Tree (N, Make_Indexed_Component (Loc, Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc), Expressions => New_List ( Make_Op_Subtract (Loc, Left_Opnd => Make_Function_Call (Loc, Name => New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc), Parameter_Associations => Exprs), Right_Opnd => Make_Integer_Literal (Loc, Uint_1))))); -- For floating-point, we transform 'Pred into a call to the Pred -- floating-point attribute function in Fat_xxx (xxx is root type) elsif Is_Floating_Point_Type (Ptyp) then Expand_Fpt_Attribute_R (N); -- For other types, if range checking is enabled, then we convert -- typ'Pred (exp) into: -- if exp = typ'Base'First then -- raise constraint_error -- else -- typ'Pred (exp) -- end; -- with the overflow check bit off in the new Pred attribute elsif Do_Overflow_Check (N) then Expand_Pred_Succ (N); -- Otherwise nothing to do else return; end if; Analyze (N); Resolve (N, Typ); end Pred; --------------- -- Remainder -- --------------- -- Transforms 'Remainder into a call to the floating-point attribute -- function Remainder in Fat_xxx (where xxx is the root type) when Attribute_Remainder => Expand_Fpt_Attribute_RR (N); ----------- -- Round -- ----------- -- A round attribute is replaced by a divide, multiply or type -- conversion node (depending on its operand), with the appropriate -- result type set, and the Rounded_Result flag set. when Attribute_Round => Round : declare Expr : constant Node_Id := Relocate_Node (First (Exprs)); Typ : constant Entity_Id := Etype (N); Rep : Node_Id; begin if Nkind (Expr) = N_Op_Divide then Rep := Make_Op_Divide (Loc, Left_Opnd => Left_Opnd (Expr), Right_Opnd => Right_Opnd (Expr)); elsif Nkind (Expr) = N_Op_Multiply then Rep := Make_Op_Multiply (Loc, Left_Opnd => Left_Opnd (Expr), Right_Opnd => Right_Opnd (Expr)); else Rep := Convert_To (Typ, Expr); end if; Set_Rounded_Result (N); Analyze (N); Resolve (N, Typ); end Round; -------------- -- Rounding -- -------------- -- Transforms 'Rounding into a call to the floating-point attribute -- function Rounding in Fat_xxx (where xxx is the root type) when Attribute_Rounding => Expand_Fpt_Attribute_R (N); ------------- -- Scaling -- ------------- -- Transforms 'Scaling into a call to the floating-point attribute -- function Scaling in Fat_xxx (where xxx is the root type) when Attribute_Scaling => Expand_Fpt_Attribute_R (N); ---------- -- Size -- ---------- -- Transforms X'Size into a call to the primitive operation _Size. -- for class-wide types. -- For other types, nothing to do, to be handled by Gigi when Attribute_Size => Size : declare Ptyp : constant Entity_Id := Etype (Pref); New_Node : Node_Id; begin if Is_Class_Wide_Type (Ptyp) then New_Node := Make_Function_Call (Loc, Name => New_Reference_To (Find_Prim_Op (Ptyp, Name_uSize), Loc), Parameter_Associations => New_List (Pref)); if Typ /= Universal_Integer then New_Node := Convert_To (Typ, New_Node); end if; Rewrite_Substitute_Tree (N, New_Node); Analyze (N); Resolve (N, Typ); end if; end Size; ------------------ -- Storage_Pool -- ------------------ when Attribute_Storage_Pool => Storage_Pool : declare Ptyp : constant Entity_Id := Base_Type (Entity (Pref)); begin Rewrite_Substitute_Tree (N, New_Reference_To (Associated_Storage_Pool (Ptyp), Loc)); Analyze (N); Resolve (N, Typ); end Storage_Pool; ------------------ -- Storage_Size -- ------------------ -- The case of access types results in a value of zero for the case -- where no storage size attribute clause has been given. If a storage -- size has been given, then the attribute is converted to a reference -- to the variable used to hold this value. -- The case of a task type (an obsolescent feature) is handled the -- same way, seems as reasonable as anything, and it is what the -- ACVC tests (e.g. CD1009K) seem to expect. -- For the case of a task object, if there is no pragma Storage_Size, -- then we also return the literal zero, otherwise if there is a -- Storage_Size pragma, then we replace the attribute reference by -- the expression: -- Universal_Integer (taskV!(name)._Size) -- to get the Size field of the record object associated with the task when Attribute_Storage_Size => Storage_Size : declare Ptyp : constant Entity_Id := Etype (Pref); begin if Is_Access_Type (Ptyp) or else (Is_Entity_Name (Pref) and then Is_Task_Type (Entity (Pref))) then if not Present (Storage_Size_Variable (Ptyp)) then Rewrite_Substitute_Tree (N, Make_Integer_Literal (Loc, Uint_0)); else Rewrite_Substitute_Tree (N, Convert_To (Typ, New_Reference_To (Storage_Size_Variable (Ptyp), Loc))); end if; Analyze (N); Resolve (N, Typ); -- Task object case else pragma Assert (Is_Task_Type (Ptyp)); declare Rtyp : constant Entity_Id := Corresponding_Record_Type (Ptyp); begin -- Task object which has Storage_Size pragma if Chars (Last_Entity (Rtyp)) = Name_uSize then Rewrite_Substitute_Tree (N, Convert_To (Universal_Integer, Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To ( Corresponding_Record_Type (Ptyp), New_Copy_Tree (Pref)), Selector_Name => Make_Identifier (Loc, Name_uSize)))); -- Task object not having Storage_Size pragma else Rewrite_Substitute_Tree (N, Make_Integer_Literal (Loc, Uint_0)); end if; end; Analyze (N); Resolve (N, Typ); end if; end Storage_Size; ---------- -- Succ -- ---------- -- 1. Deal with enumeration types with holes -- 2. For floating-point, generate call to attribute function -- 3. For other cases, deal with constraint checking when Attribute_Succ => Succ : declare Ptyp : constant Entity_Id := Base_Type (Etype (Pref)); begin -- For enumeration types with non-standard representations, we -- expand typ'Succ (x) into -- Pos_To_Rep (Rep_To_Pos (x) + 1) if Is_Enumeration_Type (Ptyp) and then Present (Enum_Pos_To_Rep (Ptyp)) then Rewrite_Substitute_Tree (N, Make_Indexed_Component (Loc, Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc), Expressions => New_List ( Make_Op_Add (Loc, Left_Opnd => Make_Function_Call (Loc, Name => New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc), Parameter_Associations => Exprs), Right_Opnd => Make_Integer_Literal (Loc, Uint_1))))); -- For floating-point, we transform 'Succ into a call to the Succ -- floating-point attribute function in Fat_xxx (xxx is root type) elsif Is_Floating_Point_Type (Ptyp) then Expand_Fpt_Attribute_R (N); -- For other types, if range checking is enabled, then we convert -- typ'Succ (exp) into: -- if exp = typ'Base'Last then -- raise constraint_error -- else -- typ'Succ (exp) -- end; -- with the overflow check bit off in the new Succ attribute elsif Do_Overflow_Check (N) then Expand_Pred_Succ (N); -- Otherwise nothing to do else return; end if; Analyze (N); Resolve (N, Typ); end Succ; --------- -- Tag -- --------- -- Transforms X'Tag into a direct reference to the tag of X when Attribute_Tag => Tag : declare Ttyp : Entity_Id; Prefix_Is_Type : Boolean; begin if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then Ttyp := Entity (Pref); Prefix_Is_Type := True; else Ttyp := Etype (Pref); Prefix_Is_Type := False; end if; if Is_Class_Wide_Type (Ttyp) then Ttyp := Root_Type (Ttyp); end if; Ttyp := Underlying_Type (Ttyp); if Prefix_Is_Type then Rewrite_Substitute_Tree (N, Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (Access_Disp_Table (Ttyp), Loc))); else Rewrite_Substitute_Tree (N, Make_Selected_Component (Loc, Prefix => Relocate_Node (Pref), Selector_Name => New_Reference_To (Tag_Component (Ttyp), Loc))); end if; Analyze (N); Resolve (N, RTE (RE_Tag)); end Tag; ---------------- -- Terminated -- ---------------- -- Transforms 'Terminated attribute into a call to Terminated function. when Attribute_Terminated => Terminated : begin Rewrite_Substitute_Tree (N, Build_Call_With_Task (Pref, RTE (RE_Terminated))); Analyze (N); Resolve (N, Standard_Boolean); end Terminated; ---------------- -- Truncation -- ---------------- -- Transforms 'Truncation into a call to the floating-point attribute -- function Truncation in Fat_xxx (where xxx is the root type) when Attribute_Truncation => Expand_Fpt_Attribute_R (N); ----------------------- -- Unbiased_Rounding -- ----------------------- -- Transforms 'Unbiased_Rounding into a call to the floating-point -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the -- root type) when Attribute_Unbiased_Rounding => Expand_Fpt_Attribute_R (N); --------- -- Val -- --------- -- For enumeration types with a standard representation, and for all -- other types, Val is handled by Gigi. For enumeration types with -- a non-standard representation we use the _Pos_To_Rep array that -- was created when the type was frozen. when Attribute_Val => Val : declare Etyp : constant Entity_Id := Base_Type (Entity (Pref)); begin if Is_Enumeration_Type (Etyp) and then Present (Enum_Pos_To_Rep (Etyp)) then Rewrite_Substitute_Tree (N, Make_Indexed_Component (Loc, Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc), Expressions => New_List (Relocate_Node (First (Exprs))))); Analyze (N); Resolve (N, Typ); end if; end Val; ----------- -- Valid -- ----------- -- For enumeration types with holes, the Pos value constructed by the -- Enum_Rep_To_Pos function built in Exp_Ch3 returns minus one for an -- invalid value, and the non-negative pos value for a valid value, so -- the expansion of X'Valid is simply: -- type(X)'Pos (X) >= 0 -- For floating-point types, we assume we are operating in IEEE mode, -- i.e. with infinities and NaN's being generated. Any valid non-zero -- floating-point value will give 1.0 when divided by itself, so we -- can expand X'Valid to: -- X = 0.0 or else X / X = 1.0 -- For all other scalar types, what we want logically is a range test: -- X in type(X)'First .. type(X)'Last -- But that's precisely what won't work because of possible unwanted -- optimization (and indeed the basic motivation for the Valid attribute -- is exactly that this test does not work. What will work is: -- Btyp!(X) >= Btyp!(type(X)'First) -- and then -- Btyp!(X) <= Btyp!(type(X)'Last) -- where Btyp is an integer type large enough to cover the full range -- of possible stored values (i.e. it is chosen on the basis of the -- size of the type, not the range of the values). We write this as -- two tests, rather than a range check, so that static evaluation -- will easily remove either or both of the checks if they can be -- statically determined to be true (this happens when the type of -- X is static and the range extends to the full range of stored -- values). when Attribute_Valid => Valid : declare Ptyp : constant Entity_Id := Etype (Pref); Btyp : Entity_Id; Exp : Multi_Use.Exp_Id; Cod : List_Id; begin -- Floating-point case if Is_Floating_Point_Type (Ptyp) then Multi_Use.Prepare (Pref, Exp, Cod); Rewrite_Substitute_Tree (N, Multi_Use.Wrap (Cod, Make_Or_Else (Loc, Left_Opnd => Make_Op_Eq (Loc, Left_Opnd => Multi_Use.New_Ref (Exp), Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), Right_Opnd => Make_Op_Eq (Loc, Left_Opnd => Make_Op_Divide (Loc, Left_Opnd => Multi_Use.New_Ref (Exp), Right_Opnd => Multi_Use.New_Ref (Exp)), Right_Opnd => Make_Real_Literal (Loc, Ureal_1))))); -- Enumeration type with holes elsif Is_Enumeration_Type (Ptyp) and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp))) then Rewrite_Substitute_Tree (N, Make_Op_Ge (Loc, Left_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Base_Type (Ptyp), Loc), Attribute_Name => Name_Pos, Expressions => New_List (Pref)), Right_Opnd => Make_Integer_Literal (Loc, Uint_0))); -- Other scalar types else Multi_Use.Prepare (Pref, Exp, Cod); if Esize (Ptyp) <= Esize (Standard_Integer) then Btyp := Standard_Integer; else Btyp := Universal_Integer; end if; -- Note below that we cannot do Unchecked_Convert_To, because -- this may subvert the required conversions and subject us to -- the dreaded optimization we are working to avoid! Rewrite_Substitute_Tree (N, Multi_Use.Wrap (Cod, Make_And_Then (Loc, Left_Opnd => Make_Op_Ge (Loc, Left_Opnd => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Btyp, Loc), Expression => Multi_Use.New_Ref (Exp)), Right_Opnd => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Btyp, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_First))), Right_Opnd => Make_Op_Le (Loc, Left_Opnd => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Btyp, Loc), Expression => Multi_Use.New_Ref (Exp)), Right_Opnd => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Btyp, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Last)))))); end if; Analyze (N); Resolve (N, Standard_Boolean); end Valid; ----------- -- Value -- ----------- -- For scalar types derived from Boolean, Character and integer types -- in package Standard, typ'Value (X) expands into: -- typ (Value_xx (X)) -- where -- For types whose root type is Character -- xx = Character -- For types whose root type is Boolean -- xx = Boolean -- For signed integer types with size <= Integer'Size -- xx = Integer -- For other signed integer types -- xx = Long_Long_Integer -- For modular types with modulus <= System.Unsigned_Types.Unsigned -- xx = Unsigned -- For other modular integer types -- xx = Long_Long_Unsigned -- For floating-point types and ordinary fixed-point types -- xx = Real -- For types derived from Wide_Character, typ'Value (X) expands into -- Value_Wide_Character (X, Wide_Character_Encoding_Method) -- For decimal types with size <= Integer'Size, typ'Value (X) -- expands into -- typ!(ctype (Value_Decimal (X, typ'Scale))); -- For all other decimal types, typ'Value (X) expands into -- typ!(ctype (Value_Long_Long_Decimal (X, typ'Scale))) -- For enumeration types other than those derived from types Boolean, -- Character, and Wide_Character in Standard, typ'Value (X) expands to: -- T'Val (Value_Enumeration (Table'Address, T'Pos (T'Last), X)) -- where Table is the table of access to string built for each -- enumeration type by Gigi (see description under documentation -- in Einfo for Lit_Name_Table). The Value_Enum procedure will -- search the table looking for X and return the position number -- in the table if found and then we will use that with the 'Val -- to return the actual enumeration value. when Attribute_Value => Value : declare Btyp : constant Entity_Id := Base_Type (Typ); Rtyp : constant Entity_Id := Root_Type (Typ); Vid : RE_Id; Args : List_Id := Exprs; Ctyp : Entity_Id; begin if Rtyp = Standard_Character then Vid := RE_Value_Character; elsif Rtyp = Standard_Boolean then Vid := RE_Value_Boolean; elsif Rtyp = Standard_Wide_Character then Vid := RE_Value_Wide_Character; Append_To (Args, Make_Integer_Literal (Loc, Intval => UI_From_Int (Int (Wide_Character_Encoding_Method)))); elsif Rtyp = Standard_Short_Short_Integer or else Rtyp = Standard_Short_Integer or else Rtyp = Standard_Integer then Vid := RE_Value_Integer; elsif Is_Signed_Integer_Type (Rtyp) then Vid := RE_Value_Long_Long_Integer; elsif Is_Modular_Integer_Type (Rtyp) then if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then Vid := RE_Value_Unsigned; else Vid := RE_Value_Long_Long_Unsigned; end if; elsif Is_Decimal_Fixed_Point_Type (Rtyp) then if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then Vid := RE_Value_Decimal; else Vid := RE_Value_Long_Long_Decimal; end if; Append_To (Args, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Typ, Loc), Attribute_Name => Name_Scale)); Rewrite_Substitute_Tree (N, Unchecked_Convert_To (Typ, Convert_To (Ctyp, Make_Function_Call (Loc, Name => New_Reference_To (RTE (Vid), Loc), Parameter_Associations => Args)))); Analyze (N); Resolve (N, Typ); elsif Is_Real_Type (Rtyp) then Vid := RE_Value_Real; -- Only other possibility is user defined enumeration type else pragma Assert (Is_Enumeration_Type (Rtyp)); Prepend_To (Args, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Btyp, Loc), Attribute_Name => Name_Pos, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Btyp, Loc), Attribute_Name => Name_Last)))); Prepend_To (Args, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Lit_Name_Table (Typ), Loc), Attribute_Name => Name_Address)); Rewrite_Substitute_Tree (N, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Typ, Loc), Attribute_Name => Name_Val, Expressions => New_List ( Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Value_Enumeration), Loc), Parameter_Associations => Args)))); Analyze (N); Resolve (N, Typ); return; end if; -- Fall through for all cases except user defined enumeration type -- and decimal types, with Vid set to the Id of the entity for the -- Value routine and Args set to the list of parameters for the call. Rewrite_Substitute_Tree (N, Convert_To (Btyp, Make_Function_Call (Loc, Name => New_Reference_To (RTE (Vid), Loc), Parameter_Associations => Args))); Analyze (N); Resolve (N, Typ); end Value; ------------- -- Version -- ------------- -- The processing for Version shares the processing for Body_Version ---------------- -- Wide_Image -- ---------------- -- We expand typ'Wide_Image (X) into -- String_To_Wide_String -- (typ'Image (X), Wide_Character_Encoding_Method) -- This works in all cases because String_To_Wide_String converts any -- wide character escape sequences resulting from the Image call to the -- proper Wide_Character equivalent -- not quite right for typ = Wide_Character ??? when Attribute_Wide_Image => Wide_Image : begin Rewrite_Substitute_Tree (N, Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_String_To_Wide_String), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => Pref, Attribute_Name => Name_Image, Expressions => Exprs), Make_Integer_Literal (Loc, Intval => UI_From_Int (Int (Wide_Character_Encoding_Method)))))); Analyze (N); Resolve (N, Standard_Wide_String); end Wide_Image; ---------------- -- Wide_Value -- ---------------- -- We expand typ'Wide_Value (X) into -- typ'Value -- (Wide_String_To_String (X, Wide_Character_Encoding_Method)) -- Wide_String_To_String is a runtime function that converts its wide -- string argument to String, converting any non-translatable characters -- into appropriate escape sequences. This preserves the required -- semantics of Wide_Value in all cases, and results in a very simple -- implementation approach. -- It's not quite right where typ = Wide_Character, because the encoding -- method may not cover the whole character type ??? when Attribute_Wide_Value => Wide_Value : begin Rewrite_Substitute_Tree (N, Make_Attribute_Reference (Loc, Prefix => Pref, Attribute_Name => Name_Value, Expressions => New_List ( Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Wide_String_To_String), Loc), Parameter_Associations => Exprs), Make_Integer_Literal (Loc, Intval => UI_From_Int (Int (Wide_Character_Encoding_Method)))))); Analyze (N); Resolve (N, Typ); end Wide_Value; ---------------- -- Wide_Width -- ---------------- -- Processing for this attribute is combined with Width ----------- -- Width -- ----------- -- The processing here also handles the case of Wide_Width. With the -- exceptions noted, the processing is identical -- For scalar types derived from Boolean, character and integer types -- in package Standard. Note that the Width attribute is computed at -- compile time for all cases except those involving non-static sub- -- types. For such subtypes, typ'Width and typ'Wide_Width expands into: -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last))) -- where -- For types whose root type is Character -- xx = Width_Character (Wide_Width_Character for Wide_Width case) -- yy = Character -- For types whose root type is Boolean -- xx = Width_Boolean -- yy = Boolean -- For signed integer types -- xx = Width_Long_Long_Integer -- yy = Long_Long_Integer -- For modular integer types -- xx = Width_Long_Long_Unsigned -- yy = Long_Long_Unsigned -- For types derived from Wide_Character, typ'Width expands into -- Result_Type (Width_Wide_Character ( -- Wide_Character (typ'First), -- Wide_Character (typ'Last), -- Wide_Character_Encoding_Method); -- and typ'Wide_Width expands into: -- Result_Type (Wide_Width_Wide_Character ( -- Wide_Character (typ'First), -- Wide_Character (typ'Last)); -- For real types, typ'Width and typ'Wide_Width expand into -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if -- where btyp is the base type. This looks recursive but it isn't -- because the base type is always static, and hence the expression -- in the else is reduced to an integer literal. -- For user defined enumeration types, typ'Width expands into -- Result_Type (Width_Enumeration (Table'Address, -- typ'Pos (typ'First), -- typ'Pos (Typ'Last))); -- and typ'Wide_Width expands into: -- Result_Type (Wide_Width_Enumeration -- (Table'Address, -- typ'Pos (typ'First), -- typ'Pos (Typ'Last)) -- Wide_Character_Encoding_Method); when Attribute_Width | Attribute_Wide_Width => Width : declare Ptyp : constant Entity_Id := Etype (Pref); Rtyp : constant Entity_Id := Root_Type (Ptyp); XX : RE_Id; YY : Entity_Id; Arglist : List_Id; begin -- Types derived from Standard.Boolean if Rtyp = Standard_Boolean then XX := RE_Width_Boolean; YY := Rtyp; -- Types derived from Standard.Character elsif Rtyp = Standard_Character then if Id = Attribute_Width then XX := RE_Width_Character; else XX := RE_Wide_Width_Character; end if; YY := Rtyp; -- Types derived from Standard.Wide_Character elsif Rtyp = Standard_Wide_Character then if Id = Attribute_Width then XX := RE_Width_Wide_Character; else XX := RE_Wide_Width_Wide_Character; end if; YY := Rtyp; -- Signed integer types elsif Is_Signed_Integer_Type (Rtyp) then XX := RE_Width_Long_Long_Integer; YY := Standard_Long_Long_Integer; -- Modular integer types elsif Is_Modular_Integer_Type (Rtyp) then XX := RE_Width_Long_Long_Unsigned; YY := RTE (RE_Long_Long_Unsigned); -- Real types elsif Is_Real_Type (Rtyp) then Rewrite_Substitute_Tree (N, Make_Conditional_Expression (Loc, Expressions => New_List ( Make_Op_Gt (Loc, Left_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_First), Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Last)), Make_Integer_Literal (Loc, Uint_0), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Base_Type (Ptyp), Loc), Attribute_Name => Name_Width)))); Analyze (N); Resolve (N, Typ); return; -- User defined enumeration types else pragma Assert (Is_Enumeration_Type (Rtyp)); if Id = Attribute_Width then XX := RE_Width_Enumeration; else XX := RE_Wide_Width_Enumeration; end if; Arglist := New_List ( Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Lit_Name_Table (Ptyp), Loc), Attribute_Name => Name_Address), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Pos, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_First))), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Pos, Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Last)))); -- For enumeration'Wide_Width, add encoding method parameter if Id = Attribute_Wide_Width then Append_To (Arglist, Make_Integer_Literal (Loc, Intval => UI_From_Int (Int (Wide_Character_Encoding_Method)))); end if; Rewrite_Substitute_Tree (N, Convert_To (Typ, Make_Function_Call (Loc, Name => New_Reference_To (RTE (XX), Loc), Parameter_Associations => Arglist))); Analyze (N); Resolve (N, Typ); return; end if; -- If we fall through XX and YY are set Arglist := New_List ( Convert_To (YY, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_First)), Convert_To (YY, Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Last))); -- For Wide_Character'Width, add encoding method parameter if Rtyp = Standard_Wide_Character and Id = Attribute_Width then Append_To (Arglist, Make_Integer_Literal (Loc, Intval => UI_From_Int (Int (Wide_Character_Encoding_Method)))); end if; Rewrite_Substitute_Tree (N, Convert_To (Typ, Make_Function_Call (Loc, Name => New_Reference_To (RTE (XX), Loc), Parameter_Associations => Arglist))); Analyze (N); Resolve (N, Typ); end Width; -- The following attributes are handled by Gigi (except that static -- cases have already been evaluated by the semantics, but in any -- case Gigi should not count on that). -- In addition Gigi handles the non-floating-point cases of Pred -- and Succ (including the fixed-point cases, which can just be -- treated as integer increment/decrement operations) -- Gigi also handles the non-class-wide cases of Size when Attribute_Access | Attribute_Aft | Attribute_Alignment | Attribute_Bit_Order | Attribute_Component_Size | Attribute_Definite | Attribute_Elab_Body | Attribute_Elab_Spec | Attribute_Max | Attribute_Max_Size_In_Storage_Elements | Attribute_Min | Attribute_Passed_By_Reference | Attribute_Range_Length | Attribute_Unchecked_Access | Attribute_Unrestricted_Access => null; -- The following attributes should not appear at this stage, since they -- have already been handled by the analyzer (and properly rewritten -- with corresponding values or entities to represent the right values) when Attribute_Abort_Signal | Attribute_Address_Size | Attribute_Base | Attribute_Caller | Attribute_Class | Attribute_Default_Bit_Order | Attribute_Delta | Attribute_Denorm | Attribute_Digits | Attribute_Emax | Attribute_Epsilon | Attribute_External_Tag | Attribute_Identity | Attribute_Input | Attribute_Large | Attribute_Machine_Emax | Attribute_Machine_Emin | Attribute_Machine_Mantissa | Attribute_Machine_Overflows | Attribute_Machine_Radix | Attribute_Machine_Rounds | Attribute_Mantissa | Attribute_Max_Interrupt_Priority | Attribute_Max_Priority | Attribute_Maximum_Alignment | Attribute_Model_Emin | Attribute_Model_Epsilon | Attribute_Model_Mantissa | Attribute_Model_Small | Attribute_Modulus | Attribute_Output | Attribute_Partition_ID | Attribute_Range | Attribute_Read | Attribute_Safe_Emax | Attribute_Safe_First | Attribute_Safe_Large | Attribute_Safe_Last | Attribute_Safe_Small | Attribute_Scale | Attribute_Signed_Zeros | Attribute_Small | Attribute_Storage_Unit | Attribute_Tick | Attribute_Universal_Literal_String | Attribute_Word_Size | Attribute_Write => pragma Assert (False); null; end case; end Expand_N_Attribute_Reference; ---------------------- -- Expand_Pred_Succ -- ---------------------- -- We expand typ'Pred (exp) into: -- if exp = typ'Base'First then -- raise constraint_error -- else -- typ'Pred (exp) -- end; -- Similarly, we expand typ'Succ (exp) into: -- if exp = typ'Base'Last then -- raise constraint_error -- else -- typ'Succ (exp) -- end procedure Expand_Pred_Succ (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Exp : Multi_Use.Exp_Id; Cod : List_Id; Cnam : Name_Id; Typ : constant Entity_Id := Base_Type (Etype (Prefix (N))); begin -- Avoid the infinite recursion implicit in the above expansion: if Nkind (Parent (N)) = N_Conditional_Expression then Set_Analyzed (N); return; end if; if Attribute_Name (N) = Name_Pred then Cnam := Name_First; else Cnam := Name_Last; end if; Multi_Use.Prepare (First (Expressions (N)), Exp, Cod); Rewrite_Substitute_Tree (N, Make_Conditional_Expression (Loc, Expressions => New_List ( Make_Op_Eq (Loc, Left_Opnd => Multi_Use.Wrap (Cod, Multi_Use.New_Ref (Exp)), Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Base_Type (Etype (Prefix (N))), Loc), Attribute_Name => Cnam)), Make_Raise_Constraint_Error (Loc), Make_Attribute_Reference (Loc, Prefix => Prefix (N), Attribute_Name => Attribute_Name (N), Expressions => New_List (Multi_Use.New_Ref (Exp)))))); -- The type of the conditional expression is the type of the Then -- expression, so we must set it here, because a Raise node has -- otherwise no semantic information. Set_Etype (Next (First (Expressions (N))), Typ); end Expand_Pred_Succ; ----------------------- -- Get_Index_Subtype -- ----------------------- function Get_Index_Subtype (N : Node_Id) return Node_Id is P_Type : constant Entity_Id := Etype (Prefix (N)); Indx : Node_Id; J : Int; begin if No (Expressions (N)) then J := 1; else J := UI_To_Int (Expr_Value (First (Expressions (N)))); end if; Indx := First_Index (P_Type); while J > 1 loop Indx := Next_Index (Indx); J := J - 1; end loop; return Etype (Indx); end Get_Index_Subtype; end Exp_Attr;