From patchwork Wed Sep 6 11:02:59 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 810510 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-461585-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="cPMRiZla"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3xnLKj3qpVz9s3w for ; Wed, 6 Sep 2017 21:03:19 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=IYmfH7KNhbZHJ0Vo7N3xBgPqaf82nolf/PutEq7s35rddNaVRw CdS4faaZpiTtW0LaG8/W8IJTGCDKvkA4PEeKqZ6Q8c29IV5zZ9m/LEWuJwTGeGiw S1jX3pjpyKhXlXsngY/cCwCY/AondVeb2cFJi58nSjOpSMAo3gg3BlWrc= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=U4JcrAZj4O8mdQPuHu+PdugTIkI=; b=cPMRiZlaSQ0QBnbM7CqH uEUKAe54DVRJpVDt7QPOCRYAkdyYKeEnFenf/t7MfCEmR/m2E8PyntrWr9GHRPUc jso4PT3xN8zpi0E717MvAL0j1NWBgN0GftPHM8pcLU0X0oRwIIL71lcULYJvZ3GL 4wi0kKU73YDPAilDTe8ccwU= Received: (qmail 35724 invoked by alias); 6 Sep 2017 11:03:11 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 35714 invoked by uid 89); 6 Sep 2017 11:03:10 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=tent, Tent, Validity X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 06 Sep 2017 11:03:00 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 4A21356145; Wed, 6 Sep 2017 07:02:59 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id ga91TEGoUT3M; Wed, 6 Sep 2017 07:02:59 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 344B656142; Wed, 6 Sep 2017 07:02:59 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 307114AC; Wed, 6 Sep 2017 07:02:59 -0400 (EDT) Date: Wed, 6 Sep 2017 07:02:59 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Justin Squirek Subject: [Ada] Extension of 'Image in Ada2020 Message-ID: <20170906110259.GA92395@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) Refactor of all 'Image attributes for better error diagnostics and clarity. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Justin Squirek * exp_imgv.adb (Expand_Image_Attribute), (Expand_Wide_Image_Attribute), (Expand_Wide_Wide_Image_Attribute): Added case to handle new-style 'Image expansion (Rewrite_Object_Image): Moved from exp_attr.adb * exp_attr.adb (Expand_N_Attribute_Reference): Modified Image attribute cases so that the relevant subprograms in exp_imgv.adb handle all expansion. (Rewrite_Object_Reference_Image): Moved to exp_imgv.adb * sem_attr.adb (Analyze_Attribute): Modified Image attribute cases to call common function Analyze_Image_Attribute. (Analyze_Image_Attribute): Created as a common path for all image attributes (Check_Object_Reference_Image): Removed * sem_util.ads, sem_util.adb (Is_Image_Applied_To_Object): Removed and refactored into Is_Object_Image (Is_Object_Image): Created as a replacement for Is_Image_Applied_To_Object 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 -- ----------------