diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/exp_imgv.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/exp_imgv.adb | 946 |
1 files changed, 946 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/exp_imgv.adb b/gcc-4.2.1/gcc/ada/exp_imgv.adb new file mode 100644 index 000000000..2f76d639b --- /dev/null +++ b/gcc-4.2.1/gcc/ada/exp_imgv.adb @@ -0,0 +1,946 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I M G V -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2005, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem_Res; use Sem_Res; +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; + +package body Exp_Imgv is + + ------------------------------------ + -- Build_Enumeration_Image_Tables -- + ------------------------------------ + + procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (E); + Str : String_Id; + Ind : List_Id; + Lit : Entity_Id; + Nlit : Nat; + Len : Nat; + Estr : Entity_Id; + Eind : Entity_Id; + Ityp : Node_Id; + + begin + -- Nothing to do for other than a root enumeration type + + if E /= Root_Type (E) then + return; + + -- Nothing to do if pragma Discard_Names applies + + elsif Discard_Names (E) then + return; + end if; + + -- Otherwise tables need constructing + + Start_String; + Ind := New_List; + Lit := First_Literal (E); + Len := 1; + Nlit := 0; + + loop + Append_To (Ind, + Make_Integer_Literal (Loc, UI_From_Int (Len))); + + exit when No (Lit); + Nlit := Nlit + 1; + + Get_Unqualified_Decoded_Name_String (Chars (Lit)); + + if Name_Buffer (1) /= ''' then + Set_Casing (All_Upper_Case); + end if; + + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Len := Len + Int (Name_Len); + Next_Literal (Lit); + end loop; + + if Len < Int (2 ** (8 - 1)) then + Ityp := Standard_Integer_8; + elsif Len < Int (2 ** (16 - 1)) then + Ityp := Standard_Integer_16; + else + Ityp := Standard_Integer_32; + end if; + + Str := End_String; + + Estr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'S')); + + Eind := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'N')); + + Set_Lit_Strings (E, Estr); + Set_Lit_Indexes (E, Eind); + + Insert_Actions (N, + New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Estr, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, + Strval => Str)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Eind, + Constant_Present => True, + + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 0), + High_Bound => Make_Integer_Literal (Loc, Nlit))), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (Ityp, Loc))), + + Expression => + Make_Aggregate (Loc, + Expressions => Ind))), + Suppress => All_Checks); + end Build_Enumeration_Image_Tables; + + ---------------------------- + -- Expand_Image_Attribute -- + ---------------------------- + + -- For all non-enumeration types, and for enumeration types declared + -- in packages Standard or System, typ'Image (Val) expands into: + + -- Image_xx (tp (Expr) [, pm]) + + -- The name xx and type conversion tp (Expr) (called tv below) depend on + -- the root type of Expr. 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 (Expr) + + -- For types whose root type is Boolean + -- xx = Boolean + -- tv = Boolean (Expr) + + -- For signed integer types with size <= Integer'Size + -- xx = Integer + -- tv = Integer (Expr) + + -- For other signed integer types + -- xx = Long_Long_Integer + -- tv = Long_Long_Integer (Expr) + + -- For modular types with modulus <= System.Unsigned_Types.Unsigned + -- xx = Unsigned + -- tv = System.Unsigned_Types.Unsigned (Expr) + + -- For other modular integer types + -- xx = Long_Long_Unsigned + -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr) + + -- For types whose root type is Wide_Character + -- xx = Wide_Character + -- tv = Wide_Character (Expr) + -- pm = Boolean, true if Ada 2005 mode, False otherwise + + -- For types whose root type is Wide_Wide_Character + -- xx = Wide_Wide_haracter + -- tv = Wide_Wide_Character (Expr) + + -- For floating-point types + -- xx = Floating_Point + -- tv = Long_Long_Float (Expr) + -- pm = typ'Digits + + -- For ordinary fixed-point types + -- xx = Ordinary_Fixed_Point + -- tv = Long_Long_Float (Expr) + -- pm = typ'Aft + + -- For decimal fixed-point types with size = Integer'Size + -- xx = Decimal + -- tv = Integer (Expr) + -- pm = typ'Scale + + -- For decimal fixed-point types with size > Integer'Size + -- xx = Long_Long_Decimal + -- tv = Long_Long_Integer (Expr) + -- pm = typ'Scale + + -- Note: for the decimal fixed-point type cases, the conversion is + -- done literally without scaling (i.e. the actual expression that + -- is generated is Image_xx (tp?(Expr) [, pm]) + + -- For enumeration types other than those declared packages Standard + -- or System, typ'Image (X) expands into: + + -- Image_Enumeration_NN (typ'Pos (X), typS, typI'Address) + + -- where typS and typI are the entities constructed as described in + -- the spec for the procedure Build_Enumeration_Image_Tables and NN + -- is 32/16/8 depending on the element type of Lit_Indexes. + + procedure Expand_Image_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Exprs : constant List_Id := Expressions (N); + Pref : constant Node_Id := Prefix (N); + 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; + Func : RE_Id; + Ttyp : Entity_Id; + Func_Ent : 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 Rtyp = Standard_Wide_Wide_Character then + Imid := RE_Image_Wide_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 + if Discard_Names (First_Subtype (Ptyp)) + or else No (Lit_Strings (Root_Type (Ptyp))) + then + -- When pragma Discard_Names applies to the first subtype, + -- then build (Pref'Pos)'Img. + + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => + Make_Attribute_Reference (Loc, + Prefix => Pref, + Attribute_Name => Name_Pos, + Expressions => New_List (Expr)), + Attribute_Name => + Name_Img)); + Analyze_And_Resolve (N, Standard_String); + + else + -- Here we get the Image of an enumeration type + + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + if Ttyp = Standard_Integer_8 then + Func := RE_Image_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + Func := RE_Image_Enumeration_16; + else + Func := RE_Image_Enumeration_32; + end if; + + -- Apply a validity check, since it is a bit drastic to + -- get a completely junk image value for an invalid value. + + if not Expr_Known_Valid (Expr) then + Insert_Valid_Check (Expr); + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Expressions => New_List (Expr)), + New_Occurrence_Of (Lit_Strings (Rtyp), Loc), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), + Attribute_Name => Name_Address)))); + + Analyze_And_Resolve (N, Standard_String); + end if; + + 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 and Imid is set to the + -- RE_Id for the function to be called. + + Func_Ent := RTE (Imid); + + -- If the function entity is empty, that means we have a case in + -- no run time mode where the operation is not allowed, and an + -- appropriate diagnostic has already been issued. + + if No (Func_Ent) then + return; + end if; + + -- Otherwise prepare arguments for run-time call + + 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 decimal, append Scale and also set to do literal conversion + + 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)); + + Set_Conversion_OK (First (Arglist)); + Set_Etype (First (Arglist), Tent); + + -- For Wide_Character, append Ada 2005 indication + + elsif Rtyp = Standard_Wide_Character then + Append_To (Arglist, + New_Reference_To (Boolean_Literals (Ada_Version >= Ada_05), Loc)); + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Func_Ent, Loc), + Parameter_Associations => Arglist)); + + Analyze_And_Resolve (N, Standard_String); + end Expand_Image_Attribute; + + ---------------------------- + -- Expand_Value_Attribute -- + ---------------------------- + + -- For scalar types derived from Boolean, Character and integer types + -- in package Standard, typ'Value (X) expands into: + + -- btyp (Value_xx (X)) + + -- where btyp is he base type of the prefix, and + + -- For types whose root type is Character + -- xx = Character + + -- For types whose root type is Wide_Character + -- xx = Wide_Character + + -- For types whose root type is Wide_Wide_Character + -- xx = Wide_Wide_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 decimal types with size <= Integer'Size, typ'Value (X) + -- expands into + + -- btyp?(Value_Decimal (X, typ'Scale)); + + -- For all other decimal types, typ'Value (X) expands into + + -- btyp?(Value_Long_Long_Decimal (X, typ'Scale)) + + -- For enumeration types other than those derived from types Boolean, + -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to: + + -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) + + -- where typS and typI and the Lit_Strings and Lit_Indexes entities + -- from T's root type entitym and Num is Enum'Pos (Enum'Last). The + -- Value_Enumeration_NN function will search the tables looking for + -- X and return the position number in the table if found which is + -- used to provide the result of 'Value (using Enum'Val). If the + -- value is not found Constraint_Error is raised. The suffix _NN + -- depends on the element type of typI. + + procedure Expand_Value_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Btyp : constant Entity_Id := Base_Type (Typ); + Rtyp : constant Entity_Id := Root_Type (Typ); + Exprs : constant List_Id := Expressions (N); + Vid : RE_Id; + Args : List_Id; + Func : RE_Id; + Ttyp : Entity_Id; + + begin + Args := Exprs; + + 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; + + elsif Rtyp = Standard_Wide_Wide_Character then + Vid := RE_Value_Wide_Wide_Character; + + elsif Rtyp = Base_Type (Standard_Short_Short_Integer) + or else Rtyp = Base_Type (Standard_Short_Integer) + or else Rtyp = Base_Type (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 (N, + OK_Convert_To (Btyp, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Vid), Loc), + Parameter_Associations => Args))); + + Set_Etype (N, Btyp); + Analyze_And_Resolve (N, Btyp); + return; + + 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)); + + -- Case of pragma Discard_Names, transform the Value + -- attribute to Btyp'Val (Long_Long_Integer'Value (Args)) + + if Discard_Names (First_Subtype (Typ)) + or else No (Lit_Strings (Rtyp)) + then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Btyp, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Long_Long_Integer, Loc), + Attribute_Name => Name_Value, + Expressions => Args)))); + + Analyze_And_Resolve (N, Btyp); + + -- Here for normal case where we have enumeration tables, this + -- is where we build + + -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X)) + + else + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + if Ttyp = Standard_Integer_8 then + Func := RE_Value_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + Func := RE_Value_Enumeration_16; + else + Func := RE_Value_Enumeration_32; + end if; + + Prepend_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Last)))); + + Prepend_To (Args, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), + Attribute_Name => Name_Address)); + + Prepend_To (Args, + New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); + + Rewrite (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 (Func), Loc), + Parameter_Associations => Args)))); + + Analyze_And_Resolve (N, Btyp); + end if; + + 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 (N, + Convert_To (Btyp, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Vid), Loc), + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Btyp); + end Expand_Value_Attribute; + + ---------------------------- + -- Expand_Width_Attribute -- + ---------------------------- + + -- The processing here also handles the case of Wide_[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'[Wide_[Wide_]]Width expands into: + + -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last))) + + -- where + + -- For types whose root type is Character + -- xx = Width_Character + -- yy = Character + + -- For types whose root type is Wide_Character + -- xx = Wide_Width_Character + -- yy = Character + + -- For types whose root type is Wide_Wide_Character + -- xx = Wide_Wide_Width_Character + -- 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), + + -- and typ'Wide_Width expands into: + + -- Result_Type (Wide_Width_Wide_Character ( + -- Wide_Character (typ'First), + -- Wide_Character (typ'Last)); + + -- and typ'Wide_Wide_Width expands into + + -- Result_Type (Wide_Wide_Width_Wide_Character ( + -- Wide_Character (typ'First), + -- Wide_Character (typ'Last)); + + -- For types derived from Wide_Wide_Character, typ'Width expands into + + -- Result_Type (Width_Wide_Wide_Character ( + -- Wide_Wide_Character (typ'First), + -- Wide_Wide_Character (typ'Last), + + -- and typ'Wide_Width expands into: + + -- Result_Type (Wide_Width_Wide_Wide_Character ( + -- Wide_Wide_Character (typ'First), + -- Wide_Wide_Character (typ'Last)); + + -- and typ'Wide_Wide_Width expands into + + -- Result_Type (Wide_Wide_Width_Wide_Wide_Char ( + -- Wide_Wide_Character (typ'First), + -- Wide_Wide_Character (typ'Last)); + + -- For real types, typ'Width and typ'Wide_[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_NN + -- (typS, + -- typI'Address, + -- typ'Pos (typ'First), + -- typ'Pos (Typ'Last))); + + -- and typ'Wide_Width expands into: + + -- Result_Type (Wide_Width_Enumeration_NN + -- (typS, + -- typI, + -- typ'Pos (typ'First), + -- typ'Pos (Typ'Last)) + -- Wide_Character_Encoding_Method); + + -- and typ'Wide_Wide_Width expands into: + + -- Result_Type (Wide_Wide_Width_Enumeration_NN + -- (typS, + -- typI, + -- typ'Pos (typ'First), + -- typ'Pos (Typ'Last)) + -- Wide_Character_Encoding_Method); + + -- where typS and typI are the enumeration image strings and + -- indexes table, as described in Build_Enumeration_Image_Tables. + -- NN is 8/16/32 for depending on the element type for typI. + + procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Etype (Pref); + Rtyp : constant Entity_Id := Root_Type (Ptyp); + XX : RE_Id; + YY : Entity_Id; + Arglist : List_Id; + Ttyp : Entity_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 + case Attr is + when Normal => XX := RE_Width_Character; + when Wide => XX := RE_Wide_Width_Character; + when Wide_Wide => XX := RE_Wide_Wide_Width_Character; + end case; + + YY := Rtyp; + + -- Types derived from Standard.Wide_Character + + elsif Rtyp = Standard_Wide_Character then + case Attr is + when Normal => XX := RE_Width_Wide_Character; + when Wide => XX := RE_Wide_Width_Wide_Character; + when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character; + end case; + + YY := Rtyp; + + -- Types derived from Standard.Wide_Wide_Character + + elsif Rtyp = Standard_Wide_Wide_Character then + case Attr is + when Normal => XX := RE_Width_Wide_Wide_Character; + when Wide => XX := RE_Wide_Width_Wide_Wide_Character; + when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char; + end case; + + 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 (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, 0), + + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Base_Type (Ptyp), Loc), + Attribute_Name => Name_Width)))); + + Analyze_And_Resolve (N, Typ); + return; + + -- User defined enumeration types + + else + pragma Assert (Is_Enumeration_Type (Rtyp)); + + if Discard_Names (Rtyp) then + + -- This is a configurable run-time, or else a restriction is in + -- effect. In either case the attribute cannot be supported. Force + -- a load error from Rtsfind to generate an appropriate message, + -- as is done with other ZFP violations. + + declare + pragma Warnings (Off); -- since Discard is unreferenced + Discard : constant Entity_Id := RTE (RE_Null); + pragma Warnings (On); + begin + return; + end; + end if; + + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + case Attr is + when Normal => + if Ttyp = Standard_Integer_8 then + XX := RE_Width_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + XX := RE_Width_Enumeration_16; + else + XX := RE_Width_Enumeration_32; + end if; + + when Wide => + if Ttyp = Standard_Integer_8 then + XX := RE_Wide_Width_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + XX := RE_Wide_Width_Enumeration_16; + else + XX := RE_Wide_Width_Enumeration_32; + end if; + + when Wide_Wide => + if Ttyp = Standard_Integer_8 then + XX := RE_Wide_Wide_Width_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + XX := RE_Wide_Wide_Width_Enumeration_16; + else + XX := RE_Wide_Wide_Width_Enumeration_32; + end if; + end case; + + Arglist := + New_List ( + New_Occurrence_Of (Lit_Strings (Rtyp), Loc), + + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), 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)))); + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (XX), Loc), + Parameter_Associations => Arglist))); + + Analyze_And_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))); + + Rewrite (N, + Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (XX), Loc), + Parameter_Associations => Arglist))); + + Analyze_And_Resolve (N, Typ); + end Expand_Width_Attribute; + +end Exp_Imgv; |