diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/exp_imgv.adb')
| -rw-r--r-- | gcc-4.4.0/gcc/ada/exp_imgv.adb | 1257 |
1 files changed, 1257 insertions, 0 deletions
diff --git a/gcc-4.4.0/gcc/ada/exp_imgv.adb b/gcc-4.4.0/gcc/ada/exp_imgv.adb new file mode 100644 index 000000000..c04fb0f3a --- /dev/null +++ b/gcc-4.4.0/gcc/ada/exp_imgv.adb @@ -0,0 +1,1257 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ I M G V -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Einfo; use Einfo; +with Exp_Util; use Exp_Util; +with Lib; use Lib; +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 cases other than user defined enumeration types, the scheme + -- is as follows. First we insert the following code: + + -- Snn : String (1 .. rt'Width); + -- Pnn : Natural; + -- Image_xx (tv, Snn, Pnn [,pm]); + -- + -- and then Expr is replaced by Snn (1 .. Pnn) + + -- In the above expansion: + + -- rt is the root type of the expression + -- tv is the expression with the value, usually a type conversion + -- pm is an extra parameter present in some cases + + -- The following table shows tv, xx, and (if used) pm for the various + -- possible types of the argument: + + -- 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_Character + -- tv = Wide_Wide_Character (Expr) + + -- For floating-point types + -- xx = Floating_Point + -- tv = Long_Long_Float (Expr) + -- pm = typ'Digits (typ = subtype of expression) + + -- For ordinary fixed-point types + -- xx = Ordinary_Fixed_Point + -- tv = Long_Long_Float (Expr) + -- pm = typ'Aft (typ = subtype of expression) + + -- For decimal fixed-point types with size = Integer'Size + -- xx = Decimal + -- tv = Integer (Expr) + -- pm = typ'Scale (typ = subtype of expression) + + -- For decimal fixed-point types with size > Integer'Size + -- xx = Long_Long_Decimal + -- tv = Long_Long_Integer?(Expr) [convert with no scaling] + -- pm = typ'Scale (typ = subtype of expression) + + -- For enumeration types other than those declared packages Standard + -- or System, Snn, Pnn, are expanded as above, but the call looks like: + + -- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address) + + -- where rt is the root type of the expression, and 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. The rewriting of the expression to + -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is + -- when pragma Discard_Names applies, in which case we replace expr by: + + -- Missing ??? + + 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; + Ttyp : Entity_Id; + Proc_Ent : Entity_Id; + Enum_Case : Boolean; + + Arg_List : List_Id; + -- List of arguments for run-time procedure call + + Ins_List : List_Id; + -- List of actions to be inserted + + Snn : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + + Pnn : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); + + begin + -- Build declarations of Snn and Pnn to be inserted + + Ins_List := New_List ( + + -- Snn : String (1 .. typ'Width); + + Make_Object_Declaration (Loc, + Defining_Identifier => Snn, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Width)))))), + + -- Pnn : Natural; + + Make_Object_Declaration (Loc, + Defining_Identifier => Pnn, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc))); + + -- Set Imid (RE_Id of procedure to call), and Tent, target for the + -- type conversion of the first argument for all possibilities. + + Enum_Case := False; + + 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); + return; + + else + -- Here for enumeration type case + + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); + + if Ttyp = Standard_Integer_8 then + Imid := RE_Image_Enumeration_8; + elsif Ttyp = Standard_Integer_16 then + Imid := RE_Image_Enumeration_16; + else + Imid := 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; + + Enum_Case := True; + end if; + end if; + + -- Build first argument for call + + if Enum_Case then + Arg_List := New_List ( + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Expressions => New_List (Expr))); + + else + Arg_List := New_List (Convert_To (Tent, Expr)); + end if; + + -- Append Snn, Pnn arguments + + Append_To (Arg_List, New_Occurrence_Of (Snn, Loc)); + Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc)); + + -- Get entity of procedure to call + + Proc_Ent := RTE (Imid); + + -- If the procedure 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 (Proc_Ent) then + return; + end if; + + -- Otherwise complete preparation of arguments for run-time call + + -- Add extra arguments for Enumeration case + + if Enum_Case then + Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc)); + Append_To (Arg_List, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc), + Attribute_Name => Name_Address)); + + -- For floating-point types, append Digits argument + + elsif Is_Floating_Point_Type (Rtyp) then + Append_To (Arg_List, + 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 (Arg_List, + 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 (Arg_List, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Scale)); + + Set_Conversion_OK (First (Arg_List)); + Set_Etype (First (Arg_List), Tent); + + -- For Wide_Character, append Ada 2005 indication + + elsif Rtyp = Standard_Wide_Character then + Append_To (Arg_List, + New_Reference_To (Boolean_Literals (Ada_Version >= Ada_05), Loc)); + end if; + + -- Now append the procedure call to the insert list + + Append_To (Ins_List, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Proc_Ent, Loc), + Parameter_Associations => Arg_List)); + + -- Insert declarations of Snn, Pnn, and the procedure call. We suppress + -- checks because we are sure that everything is in range at this stage. + + Insert_Actions (N, Ins_List, Suppress => All_Checks); + + -- Final step is to rewrite the expression as a slice and analyze, + -- again with no checks, since we are sure that everything is OK. + + Rewrite (N, + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Snn, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Pnn, Loc)))); + + Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks); + 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 + + -- 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 Wide_[Wide_]Character types, typ'Value (X) expands into: + + -- btyp (Value_xx (X, EM)) + + -- where btyp is the base type of the prefix, and EM is the encoding method + + -- 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 entity, 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; + + Append_To (Args, + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))); + + elsif Rtyp = Standard_Wide_Wide_Character then + Vid := RE_Value_Wide_Wide_Character; + + Append_To (Args, + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))); + + 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. + + -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the + -- expansion of the attribute into the function call statement to avoid + -- generating spurious errors caused by the use of Integer_Address'Value + -- in our implementation of Ada.Tags.Internal_Tag + + -- Seems like a bit of a kludge, there should be a better way ??? + + -- There is a better way, you should also test RTE_Available ??? + + if No_Run_Time_Mode + and then Rtyp = RTE (RE_Integer_Address) + and then RTU_Loaded (Ada_Tags) + and then Cunit_Entity (Current_Sem_Unit) + = Body_Entity (RTU_Entity (Ada_Tags)) + then + Rewrite (N, + Unchecked_Convert_To (Rtyp, + Make_Integer_Literal (Loc, Uint_0))); + else + Rewrite (N, + Convert_To (Btyp, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (Vid), Loc), + Parameter_Associations => Args))); + end if; + + Analyze_And_Resolve (N, Btyp); + end Expand_Value_Attribute; + + --------------------------------- + -- Expand_Wide_Image_Attribute -- + --------------------------------- + + -- We expand typ'Wide_Image (X) as follows. First we insert this code: + + -- Rnn : Wide_String (1 .. rt'Wide_Width); + -- Lnn : Natural; + -- String_To_Wide_String + -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method); + + -- where rt is the root type of the prefix type + + -- Now we replace the Wide_Image reference by + + -- Rnn (1 .. Lnn) + + -- 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 ??? + + procedure Expand_Wide_Image_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); + + Rnn : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + + Lnn : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); + + begin + Insert_Actions (N, New_List ( + + -- Rnn : Wide_String (1 .. base_typ'Width); + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_Wide_String, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Wide_Width)))))), + + -- Lnn : Natural; + + Make_Object_Declaration (Loc, + Defining_Identifier => Lnn, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)), + + -- String_To_Wide_String + -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method); + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_String_To_Wide_String), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Prefix (N), + Attribute_Name => Name_Image, + Expressions => Expressions (N)), + New_Reference_To (Rnn, Loc), + New_Reference_To (Lnn, Loc), + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))))), + + -- Suppress checks because we know everything is properly in range + + Suppress => All_Checks); + + -- Final step is to rewrite the expression as a slice and analyze, + -- again with no checks, since we are sure that everything is OK. + + Rewrite (N, + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Rnn, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Lnn, Loc)))); + + Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks); + end Expand_Wide_Image_Attribute; + + -------------------------------------- + -- Expand_Wide_Wide_Image_Attribute -- + -------------------------------------- + + -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code: + + -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); + -- Lnn : Natural; + -- String_To_Wide_Wide_String + -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method); + + -- where rt is the root type of the prefix type + + -- Now we replace the Wide_Wide_Image reference by + + -- Rnn (1 .. Lnn) + + -- This works in all cases because String_To_Wide_Wide_String converts any + -- wide character escape sequences resulting from the Image call to the + -- proper Wide_Wide_Character equivalent + + -- not quite right for typ = Wide_Wide_Character ??? + + procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); + + Rnn : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + + Lnn : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); + + begin + Insert_Actions (N, New_List ( + + -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); + + Make_Object_Declaration (Loc, + Defining_Identifier => Rnn, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Standard_Wide_Wide_String, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Wide_Wide_Width)))))), + + -- Lnn : Natural; + + Make_Object_Declaration (Loc, + Defining_Identifier => Lnn, + Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)), + + -- String_To_Wide_Wide_String + -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method); + + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_String_To_Wide_Wide_String), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Prefix (N), + Attribute_Name => Name_Image, + Expressions => Expressions (N)), + New_Reference_To (Rnn, Loc), + New_Reference_To (Lnn, Loc), + Make_Integer_Literal (Loc, + Intval => Int (Wide_Character_Encoding_Method))))), + + -- Suppress checks because we know everything is properly in range + + Suppress => All_Checks); + + -- Final step is to rewrite the expression as a slice and analyze, + -- again with no checks, since we are sure that everything is OK. + + Rewrite (N, + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Rnn, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of (Lnn, Loc)))); + + Analyze_And_Resolve + (N, Standard_Wide_Wide_String, Suppress => All_Checks); + end Expand_Wide_Wide_Image_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; |