Index: exp_imgv.adb =================================================================== --- exp_imgv.adb (revision 251753) +++ exp_imgv.adb (working copy) @@ -36,6 +36,7 @@ with Rtsfind; use Rtsfind; with Sem_Aux; use Sem_Aux; with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; @@ -52,6 +53,17 @@ -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. -- Shouldn't this be in einfo.adb or sem_aux.adb??? + procedure Rewrite_Object_Image + (N : Node_Id; + Pref : Entity_Id; + Attr_Name : Name_Id; + Str_Typ : Entity_Id); + -- AI12-00124: Rewrite attribute 'Image when it is applied to an object + -- reference as an attribute applied to a type. N denotes the node to be + -- rewritten, Pref denotes the prefix of the 'Image attribute, and Name + -- and Str_Typ specify which specific string type and 'Image attribute to + -- apply (e.g. Name_Wide_Image and Standard_Wide_String). + ------------------------------------ -- Build_Enumeration_Image_Tables -- ------------------------------------ @@ -254,10 +266,10 @@ 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; + Ptyp : Entity_Id; + Rtyp : Entity_Id; Tent : Entity_Id; Ttyp : Entity_Id; Proc_Ent : Entity_Id; @@ -273,6 +285,14 @@ Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); begin + if Is_Object_Image (Pref) then + Rewrite_Object_Image (N, Pref, Name_Image, Standard_String); + return; + end if; + + Ptyp := Entity (Pref); + Rtyp := Root_Type (Ptyp); + -- Build declarations of Snn and Pnn to be inserted Ins_List := New_List ( @@ -791,11 +811,19 @@ 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_Temporary (Loc, 'S'); - Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Pref : constant Entity_Id := Prefix (N); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Rtyp : Entity_Id; begin + if Is_Object_Image (Pref) then + Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String); + return; + end if; + + Rtyp := Root_Type (Entity (Pref)); + Insert_Actions (N, New_List ( -- Rnn : Wide_String (1 .. base_typ'Width); @@ -882,12 +910,20 @@ 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))); + Pref : constant Entity_Id := Prefix (N); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Rtyp : Entity_Id; - Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); - Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + begin + if Is_Object_Image (Pref) then + Rewrite_Object_Image + (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String); + return; + end if; - begin + Rtyp := Root_Type (Entity (Pref)); + Insert_Actions (N, New_List ( -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); @@ -1373,4 +1409,23 @@ and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); end Has_Decimal_Small; + -------------------------- + -- Rewrite_Object_Image -- + -------------------------- + + procedure Rewrite_Object_Image + (N : Node_Id; + Pref : Entity_Id; + Attr_Name : Name_Id; + Str_Typ : Entity_Id) + is + begin + Rewrite (N, + Make_Attribute_Reference (Sloc (N), + Prefix => New_Occurrence_Of (Etype (Pref), Sloc (N)), + Attribute_Name => Attr_Name, + Expressions => New_List (Relocate_Node (Pref)))); + + Analyze_And_Resolve (N, Str_Typ); + end Rewrite_Object_Image; end Exp_Imgv; Index: exp_imgv.ads =================================================================== --- exp_imgv.ads (revision 251753) +++ exp_imgv.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2017, 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- -- @@ -70,20 +70,20 @@ -- declarations are not constructed, and the fields remain Empty. procedure Expand_Image_Attribute (N : Node_Id); - -- This procedure is called from Exp_Attr to expand an occurrence - -- of the attribute Image. + -- This procedure is called from Exp_Attr to expand an occurrence of the + -- attribute Image. procedure Expand_Wide_Image_Attribute (N : Node_Id); - -- This procedure is called from Exp_Attr to expand an occurrence - -- of the attribute Wide_Image. + -- This procedure is called from Exp_Attr to expand an occurrence of the + -- attribute Wide_Image. procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id); - -- This procedure is called from Exp_Attr to expand an occurrence - -- of the attribute Wide_Wide_Image. + -- This procedure is called from Exp_Attr to expand an occurrence of the + -- attribute Wide_Wide_Image. procedure Expand_Value_Attribute (N : Node_Id); - -- This procedure is called from Exp_Attr to expand an occurrence - -- of the attribute Value. + -- This procedure is called from Exp_Attr to expand an occurrence of the + -- attribute Value. type Atype is (Normal, Wide, Wide_Wide); -- Type of attribute in call to Expand_Width_Attribute Index: exp_attr.adb =================================================================== --- exp_attr.adb (revision 251772) +++ exp_attr.adb (working copy) @@ -1594,34 +1594,10 @@ Exprs : constant List_Id := Expressions (N); Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); - procedure Rewrite_Object_Reference_Image - (Name : Name_Id; - Str_Typ : Entity_Id); - -- AI12-00124: Rewrite attribute 'Image when it is applied to an object - -- reference as an attribute applied to a type. - procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id); -- Rewrites a stream attribute for Read, Write or Output with the -- procedure call. Pname is the entity for the procedure to call. - ------------------------------------ - -- Rewrite_Object_Reference_Image -- - ------------------------------------ - - procedure Rewrite_Object_Reference_Image - (Name : Name_Id; - Str_Typ : Entity_Id) - is - begin - Rewrite (N, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Attribute_Name => Name, - Expressions => New_List (Relocate_Node (Pref)))); - - Analyze_And_Resolve (N, Str_Typ); - end Rewrite_Object_Reference_Image; - ------------------------------ -- Rewrite_Stream_Proc_Call -- ------------------------------ @@ -3637,11 +3613,6 @@ -- Image attribute is handled in separate unit Exp_Imgv when Attribute_Image => - if Is_Image_Applied_To_Object (Pref, Ptyp) then - Rewrite_Object_Reference_Image (Name_Image, Standard_String); - return; - end if; - -- Leave attribute unexpanded in CodePeer mode: the gnat2scil -- back-end knows how to handle this attribute directly. @@ -3658,7 +3629,7 @@ -- X'Img is expanded to typ'Image (X), where typ is the type of X when Attribute_Img => - Rewrite_Object_Reference_Image (Name_Image, Standard_String); + Exp_Imgv.Expand_Image_Attribute (N); ----------- -- Input -- @@ -7004,12 +6975,6 @@ -- Wide_Image attribute is handled in separate unit Exp_Imgv when Attribute_Wide_Image => - if Is_Image_Applied_To_Object (Pref, Ptyp) then - Rewrite_Object_Reference_Image - (Name_Wide_Image, Standard_Wide_String); - return; - end if; - -- Leave attribute unexpanded in CodePeer mode: the gnat2scil -- back-end knows how to handle this attribute directly. @@ -7026,12 +6991,6 @@ -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv when Attribute_Wide_Wide_Image => - if Is_Image_Applied_To_Object (Pref, Ptyp) then - Rewrite_Object_Reference_Image - (Name_Wide_Wide_Image, Standard_Wide_Wide_String); - return; - end if; - -- Leave attribute unexpanded in CodePeer mode: the gnat2scil -- back-end knows how to handle this attribute directly. Index: sem_util.adb =================================================================== --- sem_util.adb (revision 251778) +++ sem_util.adb (working copy) @@ -13773,21 +13773,6 @@ N_Generic_Subprogram_Declaration); end Is_Generic_Declaration_Or_Body; - -------------------------------- - -- Is_Image_Applied_To_Object -- - -------------------------------- - - function Is_Image_Applied_To_Object - (Prefix : Node_Id; - P_Typ : Entity_Id) return Boolean - is - begin - return - Ada_Version > Ada_2005 - and then Is_Object_Reference (Prefix) - and then Is_Scalar_Type (P_Typ); - end Is_Image_Applied_To_Object; - ---------------------------- -- Is_Inherited_Operation -- ---------------------------- @@ -14139,6 +14124,27 @@ or else Null_Present (Component_List (Type_Definition (Decl)))); end Is_Null_Record_Type; + --------------------- + -- Is_Object_Image -- + --------------------- + + function Is_Object_Image (Prefix : Node_Id) return Boolean is + begin + -- When the type of the prefix is not scalar then the prefix is not + -- valid in any senario. + + if not Is_Scalar_Type (Etype (Prefix)) then + return False; + end if; + + -- Here we test for the case that the prefix is not a type and assume + -- if it is not then it must be a named value or an object reference. + -- This is because the parser always checks that prefix's of attributes + -- are named. + + return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix))); + end Is_Object_Image; + ------------------------- -- Is_Object_Reference -- ------------------------- @@ -14222,9 +14228,9 @@ return not Nkind_In (Original_Node (N), N_Case_Expression, N_If_Expression); - -- A view conversion of a tagged object is an object reference + when N_Type_Conversion => + -- A view conversion of a tagged object is an object reference - when N_Type_Conversion => return Is_Tagged_Type (Etype (Subtype_Mark (N))) and then Is_Tagged_Type (Etype (Expression (N))) and then Is_Object_Reference (Expression (N)); Index: sem_util.ads =================================================================== --- sem_util.ads (revision 251778) +++ sem_util.ads (working copy) @@ -1598,18 +1598,6 @@ -- Determine whether arbitrary declaration Decl denotes a generic package, -- a generic subprogram or a generic body. - function Is_Image_Applied_To_Object - (Prefix : Node_Id; - P_Typ : Entity_Id) return Boolean; - -- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute - -- can be applied to a given object-reference prefix (see AI12-00124). - - -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for scalar - -- types, so that the prefix can be an object and not a type, and there is - -- no need for an argument. Given the vote of confidence from the ARG, - -- simplest is to transform this new usage of 'Image into a reference to - -- 'Img. - function Is_Inherited_Operation (E : Entity_Id) return Boolean; -- E is a subprogram. Return True is E is an implicit operation inherited -- by a derived type declaration. @@ -1683,6 +1671,15 @@ -- Determine whether T is declared with a null record definition or a -- null component list. + function Is_Object_Image (Prefix : Node_Id) return Boolean; + -- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute + -- is applied to a given object or named value prefix (see below). + + -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for scalar + -- types, so that the prefix of any 'Image attribute can be an object, a + -- named value, or a type, and there is no need for an argument in the + -- case it is an object reference. + function Is_Object_Reference (N : Node_Id) return Boolean; -- Determines if the tree referenced by N represents an object. Both -- variable and constant objects return True (compare Is_Variable). Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 251772) +++ sem_attr.adb (working copy) @@ -261,6 +261,12 @@ -- when the above criteria are met. Spec_Id denotes the entity of the -- subprogram [body] or Empty if the attribute is illegal. + procedure Analyze_Image_Attribute (Str_Typ : Entity_Id); + -- Common processing for attributes 'Img, 'Image, 'Wide_Image, and + -- 'Wide_Wide_Image. The routine checks that the prefix is valid and + -- sets the entity type to the one specified by Str_Typ (e.g. + -- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image). + procedure Bad_Attribute_For_Predicate; -- Output error message for use of a predicate (First, Last, Range) not -- allowed with a type that has predicates. If the type is a generic @@ -363,10 +369,6 @@ procedure Check_Object_Reference (P : Node_Id); -- Check that P is an object reference - procedure Check_Object_Reference_Image (Str_Typ : Entity_Id); - -- Verify that the prefix of attribute 'Image is an object reference and - -- set the type of the prefix to Str_Typ. - procedure Check_PolyORB_Attribute; -- Validity checking for PolyORB/DSA attribute @@ -1427,6 +1429,82 @@ end if; end Analyze_Attribute_Old_Result; + ----------------------------- + -- Analyze_Image_Attribute -- + ----------------------------- + + procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is + begin + Check_SPARK_05_Restriction_On_Attribute; + + -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for + -- scalar types, so that the prefix can be an object, a named value, + -- or a type, and there is no need for an argument in this case. + + if Attr_Id = Attribute_Img + or else (Ada_Version > Ada_2005 and then Is_Object_Image (P)) + then + Check_E0; + Set_Etype (N, Str_Typ); + + if Attr_Id = Attribute_Img and then not Is_Object_Image (P) then + Error_Attr_P + ("prefix of % attribute must be a scalar object name"); + end if; + else + Check_E1; + Set_Etype (N, Str_Typ); + + -- Check that the prefix type is scalar - much in the same way as + -- Check_Scalar_Type but with custom error messages to denote the + -- variants of 'Image attributes. + + if Is_Entity_Name (P) + and then Is_Type (Entity (P)) + and then Ekind (Entity (P)) = E_Incomplete_Type + and then Present (Full_View (Entity (P))) + then + P_Type := Full_View (Entity (P)); + Set_Entity (P, P_Type); + end if; + + if not Is_Entity_Name (P) + or else not Is_Type (Entity (P)) + or else not Is_Scalar_Type (P_Type) + then + if Ada_Version > Ada_2005 then + Error_Attr_P + ("prefix of % attribute must be a scalar type or a scalar " + & "object name"); + else + Error_Attr_P ("prefix of % attribute must be a scalar type"); + end if; + + elsif Is_Protected_Self_Reference (P) then + Error_Attr_P + ("prefix of % attribute denotes current instance " + & "(RM 9.4(21/2))"); + end if; + + Resolve (E1, P_Base_Type); + Validate_Non_Static_Attribute_Function_Call; + end if; + + Check_Enum_Image; + + -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source + -- to avoid giving a duplicate message for when Image attributes + -- applied to object references get expanded into type-based Image + -- attributes. + + if Restriction_Check_Required (No_Fixed_IO) + and then Comes_From_Source (N) + and then Is_Fixed_Point_Type (P_Type) + then + Check_Restriction (No_Fixed_IO, P); + end if; + end Analyze_Image_Attribute; + --------------------------------- -- Bad_Attribute_For_Predicate -- --------------------------------- @@ -2164,33 +2242,6 @@ end if; end Check_Object_Reference; - ---------------------------------- - -- Check_Object_Reference_Image -- - ---------------------------------- - - procedure Check_Object_Reference_Image (Str_Typ : Entity_Id) is - begin - Check_E0; - Set_Etype (N, Str_Typ); - - if not Is_Scalar_Type (P_Type) - or else (Is_Entity_Name (P) and then Is_Type (Entity (P))) - then - Error_Attr_P - ("prefix of % attribute must be scalar object name"); - end if; - - Check_Enum_Image; - - -- Check restriction No_Fixed_IO - - if Restriction_Check_Required (No_Fixed_IO) - and then Is_Fixed_Point_Type (P_Type) - then - Check_Restriction (No_Fixed_IO, P); - end if; - end Check_Object_Reference_Image; - ---------------------------- -- Check_PolyORB_Attribute -- ---------------------------- @@ -4073,16 +4124,6 @@ ----------- when Attribute_Image => - Check_SPARK_05_Restriction_On_Attribute; - - if Is_Image_Applied_To_Object (P, P_Type) then - Check_Object_Reference_Image (Standard_String); - return; - end if; - - Check_Scalar_Type; - Set_Etype (N, Standard_String); - if Is_Real_Type (P_Type) then if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_Name_1 := Aname; @@ -4091,31 +4132,14 @@ end if; end if; - if Is_Enumeration_Type (P_Type) then - Check_Restriction (No_Enumeration_Maps, N); - end if; + Analyze_Image_Attribute (Standard_String); - Check_E1; - Resolve (E1, P_Base_Type); - Check_Enum_Image; - Validate_Non_Static_Attribute_Function_Call; - - -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source - -- to avoid giving a duplicate message for Img expanded into Image. - - if Restriction_Check_Required (No_Fixed_IO) - and then Comes_From_Source (N) - and then Is_Fixed_Point_Type (P_Type) - then - Check_Restriction (No_Fixed_IO, P); - end if; - --------- -- Img -- --------- when Attribute_Img => - Check_Object_Reference_Image (Standard_String); + Analyze_Image_Attribute (Standard_String); ----------- -- Input -- @@ -6995,51 +7019,15 @@ ---------------- when Attribute_Wide_Image => - Check_SPARK_05_Restriction_On_Attribute; + Analyze_Image_Attribute (Standard_Wide_String); - if Is_Image_Applied_To_Object (P, P_Type) then - Check_Object_Reference_Image (Standard_Wide_String); - return; - end if; - - Check_Scalar_Type; - Set_Etype (N, Standard_Wide_String); - Check_E1; - Resolve (E1, P_Base_Type); - Validate_Non_Static_Attribute_Function_Call; - - -- Check restriction No_Fixed_IO - - if Restriction_Check_Required (No_Fixed_IO) - and then Is_Fixed_Point_Type (P_Type) - then - Check_Restriction (No_Fixed_IO, P); - end if; - --------------------- -- Wide_Wide_Image -- --------------------- when Attribute_Wide_Wide_Image => - if Is_Image_Applied_To_Object (P, P_Type) then - Check_Object_Reference_Image (Standard_Wide_Wide_String); - return; - end if; + Analyze_Image_Attribute (Standard_Wide_Wide_String); - Check_Scalar_Type; - Set_Etype (N, Standard_Wide_Wide_String); - Check_E1; - Resolve (E1, P_Base_Type); - Validate_Non_Static_Attribute_Function_Call; - - -- Check restriction No_Fixed_IO - - if Restriction_Check_Required (No_Fixed_IO) - and then Is_Fixed_Point_Type (P_Type) - then - Check_Restriction (No_Fixed_IO, P); - end if; - ---------------- -- Wide_Value -- ----------------