From: charlet Date: Fri, 18 Jul 2014 09:20:28 +0000 (+0000) Subject: 2014-07-18 Robert Dewar X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=eb66e842043b05ded0afafd335c334689d31a33a;p=thirdparty%2Fgcc.git 2014-07-18 Robert Dewar * sem_ch13.adb (Build_Discrete_Static_Predicate): New name for Build_Static_Predicate (Build_Predicate_Functions): Don't try to build discrete predicate for real type. (Build_Predicate_Functions): Report attempt to use Static_Predicate function on real type as unimplemented. * sem_util.adb (Check_Expression_Against_Static_Predicate): Add guard to prevent blow up on predicate for real type. 2014-07-18 Ed Schonberg * einfo.adb (Set_Static_Predicate): Simplify assertion to handle properly static predicate on enumeration types and modular types (not subtypes). 2014-07-18 Pierre-Marie Derodat * scos.ads (SCO_Unit_Table_Entry): Add a field to keep track of the corresponding source file index. * get_scos.ads (Get_SCOs): Add a default value for it. * par_sco.adb (SCO_Record): Fill the corresponding value. * scos.h: New. 2014-07-18 Vincent Celier * a-strunb-shared.adb, s-auxdec.ads, s-rannum.adb, atree.ads, urealp.adb, vms_data.ads, lib.ads, s-auxdec-vms_64.ads: Minor reformatting. * gnat_ugn.texi: Add documentation for new gnatmem switch -t. 2014-07-18 Thomas Quinot * g-sercom.ads (Set): document possible data loss. 2014-07-18 Ed Schonberg * exp_attr.adb (Expand_N_Attribute_Reference, cases Input, Output, Read, Write): If the restriction No_Streams is active, replace each occurrence of a stream attribute by an explicit Raise statement. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@212782 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 51c2bf8eea3f..5585fab0ea06 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2014-07-18 Robert Dewar + + * sem_ch13.adb (Build_Discrete_Static_Predicate): New name + for Build_Static_Predicate (Build_Predicate_Functions): + Don't try to build discrete predicate for real type. + (Build_Predicate_Functions): Report attempt to use + Static_Predicate function on real type as unimplemented. + * sem_util.adb (Check_Expression_Against_Static_Predicate): + Add guard to prevent blow up on predicate for real type. + +2014-07-18 Ed Schonberg + + * einfo.adb (Set_Static_Predicate): Simplify assertion to handle + properly static predicate on enumeration types and modular types + (not subtypes). + +2014-07-18 Pierre-Marie Derodat + + * scos.ads (SCO_Unit_Table_Entry): Add a field to keep track of + the corresponding source file index. + * get_scos.ads (Get_SCOs): Add a default value for it. + * par_sco.adb (SCO_Record): Fill the corresponding value. + * scos.h: New. + +2014-07-18 Vincent Celier + + * a-strunb-shared.adb, s-auxdec.ads, s-rannum.adb, atree.ads, + urealp.adb, vms_data.ads, lib.ads, s-auxdec-vms_64.ads: Minor + reformatting. + * gnat_ugn.texi: Add documentation for new gnatmem switch -t. + +2014-07-18 Thomas Quinot + + * g-sercom.ads (Set): document possible data loss. + +2014-07-18 Ed Schonberg + + * exp_attr.adb (Expand_N_Attribute_Reference, cases Input, + Output, Read, Write): If the restriction No_Streams is active, + replace each occurrence of a stream attribute by an explicit + Raise statement. + 2014-07-18 Robert Dewar * par_sco.adb, a-reatim.ads, exp_attr.adb, sem_util.adb: Minor diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb index dac8d235db1e..caeb3a02676b 100644 --- a/gcc/ada/a-strunb-shared.adb +++ b/gcc/ada/a-strunb-shared.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -1096,7 +1096,7 @@ package body Ada.Strings.Unbounded is -- Otherwise, allocate new shared string and fill it else - DR := Allocate (DL + DL /Growth_Factor); + DR := Allocate (DL + DL / Growth_Factor); DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; DR.Data (Before + New_Item'Length .. DL) := diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index e51cf88ba32b..38491d2b8ea2 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -3884,7 +3884,7 @@ package Atree is end record; pragma Pack (Node_Record); - for Node_Record'Size use 8*32; + for Node_Record'Size use 8 * 32; for Node_Record'Alignment use 4; function E_To_N is new Unchecked_Conversion (Entity_Kind, Node_Kind); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 9fc6760ba259..79da6f9e0f46 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -5736,11 +5736,7 @@ package body Einfo is procedure Set_Static_Predicate (Id : E; V : S) is begin - pragma Assert - (Ekind_In (Id, E_Enumeration_Subtype, - E_Modular_Integer_Subtype, - E_Signed_Integer_Subtype) - and then Has_Predicates (Id)); + pragma Assert (Is_Discrete_Type (Id) and then Has_Predicates (Id)); Set_List25 (Id, V); end Set_Static_Predicate; @@ -9361,7 +9357,9 @@ package body Einfo is E_Entry_Family => Write_Str ("PPC_Wrapper"); - when E_Enumeration_Subtype | + when E_Enumeration_Type | + E_Enumeration_Subtype | + E_Modular_Integer_Type | E_Modular_Integer_Subtype | E_Signed_Integer_Subtype => Write_Str ("Static_Predicate"); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 544a9232f35f..9e427b561185 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3241,6 +3241,19 @@ package body Exp_Attr is return; end if; + -- Stream operations can appear in user code even if the restriction + -- No_Streams is active (for example, when instantiating a predefined + -- container). In that case rewrite the attribute as a Raise to + -- prevent any run-time use. + + if Restriction_Active (No_Streams) then + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Explicit_Raise)); + Set_Etype (N, B_Type); + return; + end if; + -- If there is a TSS for Input, just call it Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input); @@ -4218,6 +4231,19 @@ package body Exp_Attr is return; end if; + -- Stream operations can appear in user code even if the restriction + -- No_Streams is active (for example, when instantiating a predefined + -- container). In that case rewrite the attribute as a Raise to + -- prevent any run-time use. + + if Restriction_Active (No_Streams) then + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Explicit_Raise)); + Set_Etype (N, Standard_Void_Type); + return; + end if; + -- If TSS for Output is present, just call it Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output); @@ -4845,6 +4871,19 @@ package body Exp_Attr is return; end if; + -- Stream operations can appear in user code even if the restriction + -- No_Streams is active (for example, when instantiating a predefined + -- container). In that case rewrite the attribute as a Raise to + -- prevent any run-time use. + + if Restriction_Active (No_Streams) then + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Explicit_Raise)); + Set_Etype (N, B_Type); + return; + end if; + -- The simple case, if there is a TSS for Read, just call it Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read); @@ -6545,6 +6584,19 @@ package body Exp_Attr is return; end if; + -- Stream operations can appear in user code even if the restriction + -- No_Streams is active (for example, when instantiating a predefined + -- container). In that case rewrite the attribute as a Raise to + -- prevent any run-time use. + + if Restriction_Active (No_Streams) then + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Explicit_Raise)); + Set_Etype (N, U_Type); + return; + end if; + -- The simple case, if there is a TSS for Write, just call it Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write); diff --git a/gcc/ada/g-sercom.ads b/gcc/ada/g-sercom.ads index 573eba280b6a..18ee984bb4e0 100644 --- a/gcc/ada/g-sercom.ads +++ b/gcc/ada/g-sercom.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007-2012, AdaCore -- +-- Copyright (C) 2007-2014, AdaCore -- -- -- -- 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- -- @@ -88,10 +88,13 @@ package GNAT.Serial_Communications is -- the given Timeout (in seconds) is used. If Local is set then modem -- control lines (in particular DCD) are ignored (not supported on -- Windows). Flow indicates the flow control type as defined above. - -- - -- Note that the timeout precision may be limited on some implementation + + -- Note: the timeout precision may be limited on some implementation -- (e.g. on GNU/Linux the maximum precision is a tenth of seconds). + -- Note: calling this procedure may reinitialize the serial port hardware + -- and thus cause loss of some buffered data if used during communication. + overriding procedure Read (Port : in out Serial_Port; Buffer : out Ada.Streams.Stream_Element_Array; diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index ca90a85b4f77..4f8213915767 100644 --- a/gcc/ada/get_scos.adb +++ b/gcc/ada/get_scos.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2014, 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- -- @@ -296,10 +296,11 @@ begin -- Make new unit table entry (will fill in To later) SCO_Unit_Table.Append ( - (File_Name => new String'(Buf (1 .. N)), - Dep_Num => Dnum, - From => SCO_Table.Last + 1, - To => 0)); + (File_Name => new String'(Buf (1 .. N)), + File_Index => 0, + Dep_Num => Dnum, + From => SCO_Table.Last + 1, + To => 0)); when others => raise Program_Error; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 629fac816335..83b06792c87c 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -18937,6 +18937,13 @@ currently supported criteria are @code{n, h, w} standing respectively for number of unfreed allocations, high watermark, and final watermark corresponding to a specific root. The default order is @code{nwh}. +@item -t +@cindex @option{-t} (@code{gnatmem}) +This switch causes memory allocated size to be always output in bytes. +Default @code{gnatmem} behavior is to show memory sizes less then 1 kilobyte +in bytes, from 1 kilobyte till 1 megabyte in kilobytes and the rest in +megabytes. + @end table @node Example of gnatmem Usage diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index fea2f14a1d70..0de88fec708a 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -279,9 +279,9 @@ package Lib is -- This is the number of the unit within the generated dependency -- lines (D lines in the ALI file) which are sorted into alphabetical -- order. The number is ones origin, so a value of 2 refers to the - -- second generated D line. The Dependency_Number values are set - -- as the D lines are generated, and are used to generate proper - -- unit references in the generated xref information and SCO output. + -- second generated D line. The Dependency_Num values are set as the + -- D lines are generated, and are used to generate proper unit + -- references in the generated xref information and SCO output. -- Dynamic_Elab -- A flag indicating if this unit was compiled with dynamic elaboration diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 6fe803d9e80a..0f923ca2c394 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -995,10 +995,11 @@ package body Par_SCO is -- name and dependency numbers later. SCO_Unit_Table.Append ( - (Dep_Num => 0, - File_Name => null, - From => From, - To => SCO_Table.Last)); + (Dep_Num => 0, + File_Name => null, + File_Index => Get_Source_File_Index (Sloc (Lu)), + From => From, + To => SCO_Table.Last)); SCO_Unit_Number_Table.Append (U); end SCO_Record; diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads index 8707f46f4c6e..1bac3fbac954 100644 --- a/gcc/ada/s-auxdec-vms_64.ads +++ b/gcc/ada/s-auxdec-vms_64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, 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- -- @@ -243,37 +243,37 @@ package System.Aux_DEC is -- Conventional names for static subtypes of type UNSIGNED_LONGWORD - subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1-1; - subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2-1; - subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3-1; - subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4-1; - subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5-1; - subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6-1; - subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7-1; - subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8-1; - subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9-1; - subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10-1; - subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11-1; - subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12-1; - subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13-1; - subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14-1; - subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15-1; - subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16-1; - subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17-1; - subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18-1; - subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19-1; - subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20-1; - subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21-1; - subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22-1; - subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23-1; - subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24-1; - subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25-1; - subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26-1; - subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27-1; - subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28-1; - subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29-1; - subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30-1; - subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31-1; + subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1 - 1; + subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2 - 1; + subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3 - 1; + subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4 - 1; + subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5 - 1; + subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6 - 1; + subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7 - 1; + subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8 - 1; + subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9 - 1; + subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10 - 1; + subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11 - 1; + subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12 - 1; + subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13 - 1; + subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14 - 1; + subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15 - 1; + subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16 - 1; + subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17 - 1; + subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18 - 1; + subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19 - 1; + subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20 - 1; + subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21 - 1; + subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22 - 1; + subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23 - 1; + subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24 - 1; + subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25 - 1; + subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26 - 1; + subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27 - 1; + subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28 - 1; + subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29 - 1; + subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30 - 1; + subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31 - 1; -- Function for obtaining global symbol values diff --git a/gcc/ada/s-auxdec.ads b/gcc/ada/s-auxdec.ads index a34d6089327f..59ba5ec87113 100644 --- a/gcc/ada/s-auxdec.ads +++ b/gcc/ada/s-auxdec.ads @@ -6,8 +6,6 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2011, 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- -- @@ -229,37 +227,37 @@ package System.Aux_DEC is -- Conventional names for static subtypes of type UNSIGNED_LONGWORD - subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1-1; - subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2-1; - subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3-1; - subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4-1; - subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5-1; - subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6-1; - subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7-1; - subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8-1; - subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9-1; - subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10-1; - subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11-1; - subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12-1; - subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13-1; - subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14-1; - subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15-1; - subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16-1; - subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17-1; - subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18-1; - subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19-1; - subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20-1; - subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21-1; - subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22-1; - subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23-1; - subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24-1; - subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25-1; - subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26-1; - subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27-1; - subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28-1; - subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29-1; - subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30-1; - subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31-1; + subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1 - 1; + subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2 - 1; + subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3 - 1; + subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4 - 1; + subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5 - 1; + subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6 - 1; + subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7 - 1; + subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8 - 1; + subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9 - 1; + subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10 - 1; + subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11 - 1; + subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12 - 1; + subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13 - 1; + subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14 - 1; + subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15 - 1; + subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16 - 1; + subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17 - 1; + subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18 - 1; + subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19 - 1; + subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20 - 1; + subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21 - 1; + subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22 - 1; + subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23 - 1; + subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24 - 1; + subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25 - 1; + subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26 - 1; + subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27 - 1; + subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28 - 1; + subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29 - 1; + subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30 - 1; + subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31 - 1; -- Function for obtaining global symbol values diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb index bfcea5569443..af620d704206 100644 --- a/gcc/ada/s-rannum.adb +++ b/gcc/ada/s-rannum.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2014, 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- -- @@ -103,7 +103,7 @@ package body System.Random_Numbers is -- Algorithmic Parameters -- ---------------------------- - Lower_Mask : constant := 2**31-1; + Lower_Mask : constant := 2**31 - 1; Upper_Mask : constant := 2**31; Matrix_A : constant array (State_Val range 0 .. 1) of State_Val diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 6efc5cebcc9a..0758f48cd027 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2014, 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- -- @@ -49,6 +49,9 @@ package SCOs is -- Put_SCO reads the internal tables and generates text lines in the ALI -- format. + -- WARNING: There are C bindings for this package. Any changes to this + -- source file must be properly reflected in the C header file scos.h + -------------------- -- SCO ALI Format -- -------------------- @@ -497,6 +500,9 @@ package SCOs is File_Name : String_Ptr; -- Pointer to file name in ALI file + File_Index : Source_File_Index; + -- Index for the source file + Dep_Num : Nat; -- Dependency number in ALI file diff --git a/gcc/ada/scos.h b/gcc/ada/scos.h new file mode 100644 index 000000000000..d997c9df83a9 --- /dev/null +++ b/gcc/ada/scos.h @@ -0,0 +1,88 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * S C O S * + * * + * C Header File * + * * + * Copyright (C) 2014, 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. * + * * + ****************************************************************************/ + +/* This is the C file that corresponds to the Ada package spec SCOs. It was + created manually from the file scos.ads. */ + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Unit table: */ + +typedef Int SCO_Unit_Index; + +struct SCO_Unit_Table_Entry + { + Fat_Pointer File_Name; + Int File_Index; + Nat Dep_Num; + Nat From, To; + }; + +typedef struct SCO_Unit_Table_Entry *SCO_Unit_Table_Type; + +extern SCO_Unit_Table_Type scos__sco_unit_table__table; +#define SCO_Unit_Table scos__sco_unit_table__table + +extern Int scos__sco_unit_table__min; +#define SCO_Unit_Table_Min scos__sco_unit_table__min + +extern Int scos__sco_unit_table__last_val; +#define SCO_Unit_Table_Last_Val scos__sco_unit_table__last_val + + +/* SCOs table: */ + +struct Source_Location + { + Line_Number_Type Line; + Column_Number_Type Col; + }; + +struct SCO_Table_Entry + { + struct Source_Location From, To; + char C1, C2; + bool Last; + Source_Ptr Pragma_Sloc; + Name_Id Pragma_Aspect_Name; + }; + +typedef struct SCO_Table_Entry *SCO_Table_Type; + +extern SCO_Table_Type scos__sco_table__table; +#define SCO_Table scos__sco_table__table + +extern Int scos__sco_table__min; +#define SCO_Table_Min scos__sco_table__min + +extern Int scos__sco_table__last_val; +#define SCO_Table_Last_Val scos__sco_table__last_val + +#ifdef __cplusplus +} +#endif diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index be28f94a1d83..a9cdc2cb533e 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -84,19 +84,7 @@ package body Sem_Ch13 is -- type whose inherited alignment is no longer appropriate for the new -- size value. In this case, we reset the Alignment to unknown. - procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id); - -- If Typ has predicates (indicated by Has_Predicates being set for Typ), - -- then either there are pragma Predicate entries on the rep chain for the - -- type (note that Predicate aspects are converted to pragma Predicate), or - -- there are inherited aspects from a parent type, or ancestor subtypes. - -- This procedure builds the spec and body for the Predicate function that - -- tests these predicates. N is the freeze node for the type. The spec of - -- the function is inserted before the freeze node, and the body of the - -- function is inserted after the freeze node. If the predicate expression - -- has at least one Raise_Expression, then this procedure also builds the - -- M version of the predicate function for use in membership tests. - - procedure Build_Static_Predicate + procedure Build_Discrete_Static_Predicate (Typ : Entity_Id; Expr : Node_Id; Nam : Name_Id); @@ -111,6 +99,18 @@ package body Sem_Ch13 is -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as -- a canonicalized membership operation. + procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id); + -- If Typ has predicates (indicated by Has_Predicates being set for Typ), + -- then either there are pragma Predicate entries on the rep chain for the + -- type (note that Predicate aspects are converted to pragma Predicate), or + -- there are inherited aspects from a parent type, or ancestor subtypes. + -- This procedure builds the spec and body for the Predicate function that + -- tests these predicates. N is the freeze node for the type. The spec of + -- the function is inserted before the freeze node, and the body of the + -- function is inserted after the freeze node. If the predicate expression + -- has at least one Raise_Expression, then this procedure also builds the + -- M version of the predicate function for use in membership tests. + procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id); -- Called if both Storage_Pool and Storage_Size attribute definition -- clauses (SP and SS) are present for entity Ent. Issue error message. @@ -6154,1864 +6154,1855 @@ package body Sem_Ch13 is end if; end Analyze_Record_Representation_Clause; - ------------------------------------------- - -- Build_Invariant_Procedure_Declaration -- - ------------------------------------------- + ------------------------------------- + -- Build_Discrete_Static_Predicate -- + ------------------------------------- - function Build_Invariant_Procedure_Declaration - (Typ : Entity_Id) return Node_Id + procedure Build_Discrete_Static_Predicate + (Typ : Entity_Id; + Expr : Node_Id; + Nam : Name_Id) is - Loc : constant Source_Ptr := Sloc (Typ); - Object_Entity : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('I')); - Spec : Node_Id; - SId : Entity_Id; + Loc : constant Source_Ptr := Sloc (Expr); - begin - Set_Etype (Object_Entity, Typ); + Non_Static : exception; + -- Raised if something non-static is found - -- Check for duplicate definiations. + Btyp : constant Entity_Id := Base_Type (Typ); - if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then - return Empty; - end if; + BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp)); + BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp)); + -- Low bound and high bound value of base type of Typ - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Invariant")); - Set_Has_Invariants (Typ); - Set_Ekind (SId, E_Procedure); - Set_Is_Invariant_Procedure (SId); - Set_Invariant_Procedure (Typ, SId); + TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ)); + THi : constant Uint := Expr_Value (Type_High_Bound (Typ)); + -- Low bound and high bound values of static subtype Typ - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity, - Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + type REnt is record + Lo, Hi : Uint; + end record; + -- One entry in a Rlist value, a single REnt (range entry) value denotes + -- one range from Lo to Hi. To represent a single value range Lo = Hi = + -- value. - return Make_Subprogram_Declaration (Loc, Specification => Spec); - end Build_Invariant_Procedure_Declaration; + type RList is array (Nat range <>) of REnt; + -- A list of ranges. The ranges are sorted in increasing order, and are + -- disjoint (there is a gap of at least one value between each range in + -- the table). A value is in the set of ranges in Rlist if it lies + -- within one of these ranges. - ------------------------------- - -- Build_Invariant_Procedure -- - ------------------------------- + False_Range : constant RList := + RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); + -- An empty set of ranges represents a range list that can never be + -- satisfied, since there are no ranges in which the value could lie, + -- so it does not lie in any of them. False_Range is a canonical value + -- for this empty set, but general processing should test for an Rlist + -- with length zero (see Is_False predicate), since other null ranges + -- may appear which must be treated as False. - -- The procedure that is constructed here has the form + True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); + -- Range representing True, value must be in the base range - -- procedure typInvariant (Ixxx : typ) is - -- begin - -- pragma Check (Invariant, exp, "failed invariant from xxx"); - -- pragma Check (Invariant, exp, "failed invariant from xxx"); - -- ... - -- pragma Check (Invariant, exp, "failed inherited invariant from xxx"); - -- ... - -- end typInvariant; + function "and" (Left : RList; Right : RList) return RList; + -- And's together two range lists, returning a range list. This is a set + -- intersection operation. - procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is - Loc : constant Source_Ptr := Sloc (Typ); - Stmts : List_Id; - Spec : Node_Id; - SId : Entity_Id; - PDecl : Node_Id; - PBody : Node_Id; + function "or" (Left : RList; Right : RList) return RList; + -- Or's together two range lists, returning a range list. This is a set + -- union operation. - Nam : Name_Id; - -- Name for Check pragma, usually Invariant, but might be Type_Invariant - -- if we come from a Type_Invariant aspect, we make sure to build the - -- Check pragma with the right name, so that Check_Policy works right. + function "not" (Right : RList) return RList; + -- Returns complement of a given range list, i.e. a range list + -- representing all the values in TLo .. THi that are not in the input + -- operand Right. - Visible_Decls : constant List_Id := Visible_Declarations (N); - Private_Decls : constant List_Id := Private_Declarations (N); + function Build_Val (V : Uint) return Node_Id; + -- Return an analyzed N_Identifier node referencing this value, suitable + -- for use as an entry in the Static_Predicate list. This node is typed + -- with the base type. - procedure Add_Invariants (T : Entity_Id; Inherit : Boolean); - -- Appends statements to Stmts for any invariants in the rep item chain - -- of the given type. If Inherit is False, then we only process entries - -- on the chain for the type Typ. If Inherit is True, then we ignore any - -- Invariant aspects, but we process all Invariant'Class aspects, adding - -- "inherited" to the exception message and generating an informational - -- message about the inheritance of an invariant. + function Build_Range (Lo : Uint; Hi : Uint) return Node_Id; + -- Return an analyzed N_Range node referencing this range, suitable for + -- use as an entry in the Static_Predicate list. This node is typed with + -- the base type. - Object_Name : Name_Id; - -- Name for argument of invariant procedure + function Get_RList (Exp : Node_Id) return RList; + -- This is a recursive routine that converts the given expression into a + -- list of ranges, suitable for use in building the static predicate. - Object_Entity : Node_Id; - -- The entity of the formal for the procedure + function Is_False (R : RList) return Boolean; + pragma Inline (Is_False); + -- Returns True if the given range list is empty, and thus represents a + -- False list of ranges that can never be satisfied. - -------------------- - -- Add_Invariants -- - -------------------- + function Is_True (R : RList) return Boolean; + -- Returns True if R trivially represents the True predicate by having a + -- single range from BLo to BHi. - procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is - Ritem : Node_Id; - Arg1 : Node_Id; - Arg2 : Node_Id; - Arg3 : Node_Id; - Exp : Node_Id; - Loc : Source_Ptr; - Assoc : List_Id; - Str : String_Id; + function Is_Type_Ref (N : Node_Id) return Boolean; + pragma Inline (Is_Type_Ref); + -- Returns if True if N is a reference to the type for the predicate in + -- the expression (i.e. if it is an identifier whose Chars field matches + -- the Nam given in the call). - procedure Replace_Type_Reference (N : Node_Id); - -- Replace a single occurrence N of the subtype name with a reference - -- to the formal of the predicate function. N can be an identifier - -- referencing the subtype, or a selected component, representing an - -- appropriately qualified occurrence of the subtype name. + function Lo_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value or low bound of range. - procedure Replace_Type_References is - new Replace_Type_References_Generic (Replace_Type_Reference); - -- Traverse an expression replacing all occurrences of the subtype - -- name with appropriate references to the object that is the formal - -- parameter of the predicate function. Note that we must ensure - -- that the type and entity information is properly set in the - -- replacement node, since we will do a Preanalyze call of this - -- expression without proper visibility of the procedure argument. + function Hi_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value of high bound of range. - ---------------------------- - -- Replace_Type_Reference -- - ---------------------------- + function Membership_Entry (N : Node_Id) return RList; + -- Given a single membership entry (range, value, or subtype), returns + -- the corresponding range list. Raises Static_Error if not static. - -- Note: See comments in Add_Predicates.Replace_Type_Reference - -- regarding handling of Sloc and Comes_From_Source. + function Membership_Entries (N : Node_Id) return RList; + -- Given an element on an alternatives list of a membership operation, + -- returns the range list corresponding to this entry and all following + -- entries (i.e. returns the "or" of this list of values). - procedure Replace_Type_Reference (N : Node_Id) is - begin + function Stat_Pred (Typ : Entity_Id) return RList; + -- Given a type, if it has a static predicate, then return the predicate + -- as a range list, otherwise raise Non_Static. - -- Add semantic information to node to be rewritten, for ASIS - -- navigation needs. + ----------- + -- "and" -- + ----------- - if Nkind (N) = N_Identifier then - Set_Entity (N, T); - Set_Etype (N, T); + function "and" (Left : RList; Right : RList) return RList is + FEnt : REnt; + -- First range of result - elsif Nkind (N) = N_Selected_Component then - Analyze (Prefix (N)); - Set_Entity (Selector_Name (N), T); - Set_Etype (Selector_Name (N), T); - end if; + SLeft : Nat := Left'First; + -- Start of rest of left entries - -- Invariant'Class, replace with T'Class (obj) + SRight : Nat := Right'First; + -- Start of rest of right entries - if Class_Present (Ritem) then - Rewrite (N, - Make_Type_Conversion (Sloc (N), - Subtype_Mark => - Make_Attribute_Reference (Sloc (N), - Prefix => New_Occurrence_Of (T, Sloc (N)), - Attribute_Name => Name_Class), - Expression => Make_Identifier (Sloc (N), Object_Name))); + begin + -- If either range is True, return the other - Set_Entity (Expression (N), Object_Entity); - Set_Etype (Expression (N), Typ); + if Is_True (Left) then + return Right; + elsif Is_True (Right) then + return Left; + end if; - -- Invariant, replace with obj + -- If either range is False, return False - else - Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); - Set_Entity (N, Object_Entity); - Set_Etype (N, Typ); - end if; + if Is_False (Left) or else Is_False (Right) then + return False_Range; + end if; - Set_Comes_From_Source (N, True); - end Replace_Type_Reference; + -- Loop to remove entries at start that are disjoint, and thus just + -- get discarded from the result entirely. - -- Start of processing for Add_Invariants + loop + -- If no operands left in either operand, result is false - begin - Ritem := First_Rep_Item (T); - while Present (Ritem) loop - if Nkind (Ritem) = N_Pragma - and then Pragma_Name (Ritem) = Name_Invariant - then - Arg1 := First (Pragma_Argument_Associations (Ritem)); - Arg2 := Next (Arg1); - Arg3 := Next (Arg2); + if SLeft > Left'Last or else SRight > Right'Last then + return False_Range; - Arg1 := Get_Pragma_Arg (Arg1); - Arg2 := Get_Pragma_Arg (Arg2); + -- Discard first left operand entry if disjoint with right - -- For Inherit case, ignore Invariant, process only Class case + elsif Left (SLeft).Hi < Right (SRight).Lo then + SLeft := SLeft + 1; - if Inherit then - if not Class_Present (Ritem) then - goto Continue; - end if; + -- Discard first right operand entry if disjoint with left - -- For Inherit false, process only item for right type + elsif Right (SRight).Hi < Left (SLeft).Lo then + SRight := SRight + 1; - else - if Entity (Arg1) /= Typ then - goto Continue; - end if; - end if; + -- Otherwise we have an overlapping entry - if No (Stmts) then - Stmts := Empty_List; - end if; + else + exit; + end if; + end loop; - Exp := New_Copy_Tree (Arg2); + -- Now we have two non-null operands, and first entries overlap. The + -- first entry in the result will be the overlapping part of these + -- two entries. - -- Preserve sloc of original pragma Invariant + FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), + Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); - Loc := Sloc (Ritem); + -- Now we can remove the entry that ended at a lower value, since its + -- contribution is entirely contained in Fent. - -- We need to replace any occurrences of the name of the type - -- with references to the object, converted to type'Class in - -- the case of Invariant'Class aspects. + if Left (SLeft).Hi <= Right (SRight).Hi then + SLeft := SLeft + 1; + else + SRight := SRight + 1; + end if; - Replace_Type_References (Exp, Chars (T)); + -- Compute result by concatenating this first entry with the "and" of + -- the remaining parts of the left and right operands. Note that if + -- either of these is empty, "and" will yield empty, so that we will + -- end up with just Fent, which is what we want in that case. - -- If this invariant comes from an aspect, find the aspect - -- specification, and replace the saved expression because - -- we need the subtype references replaced for the calls to - -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point - -- and Check_Aspect_At_End_Of_Declarations. + return + FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); + end "and"; - if From_Aspect_Specification (Ritem) then - declare - Aitem : Node_Id; + ----------- + -- "not" -- + ----------- - begin - -- Loop to find corresponding aspect, note that this - -- must be present given the pragma is marked delayed. + function "not" (Right : RList) return RList is + begin + -- Return True if False range - -- Note: in practice Next_Rep_Item (Ritem) is Empty so - -- this loop does nothing. Furthermore, why isn't this - -- simply Corresponding_Aspect ??? + if Is_False (Right) then + return True_Range; + end if; - Aitem := Next_Rep_Item (Ritem); - while Present (Aitem) loop - if Nkind (Aitem) = N_Aspect_Specification - and then Aspect_Rep_Item (Aitem) = Ritem - then - Set_Entity - (Identifier (Aitem), New_Copy_Tree (Exp)); - exit; - end if; + -- Return False if True range - Aitem := Next_Rep_Item (Aitem); - end loop; - end; - end if; + if Is_True (Right) then + return False_Range; + end if; - -- Now we need to preanalyze the expression to properly capture - -- the visibility in the visible part. The expression will not - -- be analyzed for real until the body is analyzed, but that is - -- at the end of the private part and has the wrong visibility. + -- Here if not trivial case - Set_Parent (Exp, N); - Preanalyze_Assert_Expression (Exp, Standard_Boolean); + declare + Result : RList (1 .. Right'Length + 1); + -- May need one more entry for gap at beginning and end - -- In ASIS mode, even if assertions are not enabled, we must - -- analyze the original expression in the aspect specification - -- because it is part of the original tree. + Count : Nat := 0; + -- Number of entries stored in Result - if ASIS_Mode and then From_Aspect_Specification (Ritem) then - declare - Inv : constant Node_Id := - Expression (Corresponding_Aspect (Ritem)); - begin - Replace_Type_References (Inv, Chars (T)); - Preanalyze_Assert_Expression (Inv, Standard_Boolean); - end; - end if; + begin + -- Gap at start - -- Get name to be used for Check pragma + if Right (Right'First).Lo > TLo then + Count := Count + 1; + Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); + end if; - if not From_Aspect_Specification (Ritem) then - Nam := Name_Invariant; - else - Nam := Chars (Identifier (Corresponding_Aspect (Ritem))); - end if; + -- Gaps between ranges - -- Build first two arguments for Check pragma + for J in Right'First .. Right'Last - 1 loop + Count := Count + 1; + Result (Count) := REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); + end loop; - Assoc := - New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Chars => Nam)), - Make_Pragma_Argument_Association (Loc, - Expression => Exp)); + -- Gap at end - -- Add message if present in Invariant pragma + if Right (Right'Last).Hi < THi then + Count := Count + 1; + Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); + end if; - if Present (Arg3) then - Str := Strval (Get_Pragma_Arg (Arg3)); + return Result (1 .. Count); + end; + end "not"; - -- If inherited case, and message starts "failed invariant", - -- change it to be "failed inherited invariant". + ---------- + -- "or" -- + ---------- - if Inherit then - String_To_Name_Buffer (Str); + function "or" (Left : RList; Right : RList) return RList is + FEnt : REnt; + -- First range of result - if Name_Buffer (1 .. 16) = "failed invariant" then - Insert_Str_In_Name_Buffer ("inherited ", 8); - Str := String_From_Name_Buffer; - end if; - end if; + SLeft : Nat := Left'First; + -- Start of rest of left entries - Append_To (Assoc, - Make_Pragma_Argument_Association (Loc, - Expression => Make_String_Literal (Loc, Str))); - end if; + SRight : Nat := Right'First; + -- Start of rest of right entries - -- Add Check pragma to list of statements + begin + -- If either range is True, return True - Append_To (Stmts, - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Loc, Name_Check), - Pragma_Argument_Associations => Assoc)); + if Is_True (Left) or else Is_True (Right) then + return True_Range; + end if; - -- If Inherited case and option enabled, output info msg. Note - -- that we know this is a case of Invariant'Class. + -- If either range is False (empty), return the other - if Inherit and Opt.List_Inherited_Aspects then - Error_Msg_Sloc := Sloc (Ritem); - Error_Msg_N - ("info: & inherits `Invariant''Class` aspect from #?L?", - Typ); - end if; - end if; + if Is_False (Left) then + return Right; + elsif Is_False (Right) then + return Left; + end if; - <> - Next_Rep_Item (Ritem); - end loop; - end Add_Invariants; + -- Initialize result first entry from left or right operand depending + -- on which starts with the lower range. - -- Start of processing for Build_Invariant_Procedure + if Left (SLeft).Lo < Right (SRight).Lo then + FEnt := Left (SLeft); + SLeft := SLeft + 1; + else + FEnt := Right (SRight); + SRight := SRight + 1; + end if; - begin - Stmts := No_List; - PDecl := Empty; - PBody := Empty; - SId := Empty; + -- This loop eats ranges from left and right operands that are + -- contiguous with the first range we are gathering. - -- If the aspect specification exists for some view of the type, the - -- declaration for the procedure has been created. + loop + -- Eat first entry in left operand if contiguous or overlapped by + -- gathered first operand of result. - if Has_Invariants (Typ) then - SId := Invariant_Procedure (Typ); - end if; + if SLeft <= Left'Last + and then Left (SLeft).Lo <= FEnt.Hi + 1 + then + FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); + SLeft := SLeft + 1; - if Present (SId) then - PDecl := Unit_Declaration_Node (SId); - else - PDecl := Build_Invariant_Procedure_Declaration (Typ); - end if; + -- Eat first entry in right operand if contiguous or overlapped by + -- gathered right operand of result. - -- Recover formal of procedure, for use in the calls to invariant - -- functions (including inherited ones). + elsif SRight <= Right'Last + and then Right (SRight).Lo <= FEnt.Hi + 1 + then + FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); + SRight := SRight + 1; - Object_Entity := - Defining_Identifier - (First (Parameter_Specifications (Specification (PDecl)))); - Object_Name := Chars (Object_Entity); + -- All done if no more entries to eat - -- Add invariants for the current type + else + exit; + end if; + end loop; - Add_Invariants (Typ, Inherit => False); + -- Obtain result as the first entry we just computed, concatenated + -- to the "or" of the remaining results (if one operand is empty, + -- this will just concatenate with the other - -- Add invariants for parent types + return + FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); + end "or"; - declare - Current_Typ : Entity_Id; - Parent_Typ : Entity_Id; + ----------------- + -- Build_Range -- + ----------------- + function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is + Result : Node_Id; begin - Current_Typ := Typ; - loop - Parent_Typ := Etype (Current_Typ); - - if Is_Private_Type (Parent_Typ) - and then Present (Full_View (Base_Type (Parent_Typ))) - then - Parent_Typ := Full_View (Base_Type (Parent_Typ)); - end if; - - exit when Parent_Typ = Current_Typ; + Result := + Make_Range (Loc, + Low_Bound => Build_Val (Lo), + High_Bound => Build_Val (Hi)); + Set_Etype (Result, Btyp); + Set_Analyzed (Result); + return Result; + end Build_Range; - Current_Typ := Parent_Typ; - Add_Invariants (Current_Typ, Inherit => True); - end loop; - end; + --------------- + -- Build_Val -- + --------------- - -- Build the procedure if we generated at least one Check pragma + function Build_Val (V : Uint) return Node_Id is + Result : Node_Id; - if Stmts /= No_List then - Spec := Copy_Separate_Tree (Specification (PDecl)); + begin + if Is_Enumeration_Type (Typ) then + Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); + else + Result := Make_Integer_Literal (Loc, V); + end if; - PBody := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts)); + Set_Etype (Result, Btyp); + Set_Is_Static_Expression (Result); + Set_Analyzed (Result); + return Result; + end Build_Val; - -- Insert procedure declaration and spec at the appropriate points. - -- If declaration is already analyzed, it was processed by the - -- generated pragma. + --------------- + -- Get_RList -- + --------------- - if Present (Private_Decls) then + function Get_RList (Exp : Node_Id) return RList is + Op : Node_Kind; + Val : Uint; - -- The spec goes at the end of visible declarations, but they have - -- already been analyzed, so we need to explicitly do the analyze. + begin + -- Static expression can only be true or false - if not Analyzed (PDecl) then - Append_To (Visible_Decls, PDecl); - Analyze (PDecl); + if Is_OK_Static_Expression (Exp) then + if Expr_Value (Exp) = 0 then + return False_Range; + else + return True_Range; end if; + end if; - -- The body goes at the end of the private declarations, which we - -- have not analyzed yet, so we do not need to perform an explicit - -- analyze call. We skip this if there are no private declarations - -- (this is an error that will be caught elsewhere); - - Append_To (Private_Decls, PBody); + -- Otherwise test node type - -- If the invariant appears on the full view of a type, the - -- analysis of the private part is complete, and we must - -- analyze the new body explicitly. + Op := Nkind (Exp); - if In_Private_Part (Current_Scope) then - Analyze (PBody); - end if; + case Op is - -- If there are no private declarations this may be an error that - -- will be diagnosed elsewhere. However, if this is a non-private - -- type that inherits invariants, it needs no completion and there - -- may be no private part. In this case insert invariant procedure - -- at end of current declarative list, and analyze at once, given - -- that the type is about to be frozen. + -- And - elsif not Is_Private_Type (Typ) then - Append_To (Visible_Decls, PDecl); - Append_To (Visible_Decls, PBody); - Analyze (PDecl); - Analyze (PBody); - end if; - end if; - end Build_Invariant_Procedure; + when N_Op_And | N_And_Then => + return Get_RList (Left_Opnd (Exp)) + and + Get_RList (Right_Opnd (Exp)); - ------------------------------- - -- Build_Predicate_Functions -- - ------------------------------- + -- Or - -- The procedures that are constructed here have the form: + when N_Op_Or | N_Or_Else => + return Get_RList (Left_Opnd (Exp)) + or + Get_RList (Right_Opnd (Exp)); - -- function typPredicate (Ixxx : typ) return Boolean is - -- begin - -- return - -- exp1 and then exp2 and then ... - -- and then typ1Predicate (typ1 (Ixxx)) - -- and then typ2Predicate (typ2 (Ixxx)) - -- and then ...; - -- end typPredicate; + -- Not - -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that - -- this is the point at which these expressions get analyzed, providing the - -- required delay, and typ1, typ2, are entities from which predicates are - -- inherited. Note that we do NOT generate Check pragmas, that's because we - -- use this function even if checks are off, e.g. for membership tests. + when N_Op_Not => + return not Get_RList (Right_Opnd (Exp)); - -- If the expression has at least one Raise_Expression, then we also build - -- the typPredicateM version of the function, in which any occurrence of a - -- Raise_Expression is converted to "return False". + -- Comparisons of type with static value - procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is - Loc : constant Source_Ptr := Sloc (Typ); + when N_Op_Compare => - Expr : Node_Id; - -- This is the expression for the result of the function. It is - -- is build by connecting the component predicates with AND THEN. + -- Type is left operand - Expr_M : Node_Id; - -- This is the corresponding return expression for the Predicate_M - -- function. It differs in that raise expressions are marked for - -- special expansion (see Process_REs). + if Is_Type_Ref (Left_Opnd (Exp)) + and then Is_OK_Static_Expression (Right_Opnd (Exp)) + then + Val := Expr_Value (Right_Opnd (Exp)); - Object_Name : constant Name_Id := New_Internal_Name ('I'); - -- Name for argument of Predicate procedure. Note that we use the same - -- name for both predicate procedure. That way the reference within the - -- predicate expression is the same in both functions. + -- Typ is right operand - Object_Entity : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars => Object_Name); - -- Entity for argument of Predicate procedure + elsif Is_Type_Ref (Right_Opnd (Exp)) + and then Is_OK_Static_Expression (Left_Opnd (Exp)) + then + Val := Expr_Value (Left_Opnd (Exp)); - Object_Entity_M : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars => Object_Name); - -- Entity for argument of Predicate_M procedure + -- Invert sense of comparison - Raise_Expression_Present : Boolean := False; - -- Set True if Expr has at least one Raise_Expression + case Op is + when N_Op_Gt => Op := N_Op_Lt; + when N_Op_Lt => Op := N_Op_Gt; + when N_Op_Ge => Op := N_Op_Le; + when N_Op_Le => Op := N_Op_Ge; + when others => null; + end case; - Static_Predic : Node_Id := Empty; - -- Set to N_Pragma node for a static predicate if one is encountered + -- Other cases are non-static - procedure Add_Call (T : Entity_Id); - -- Includes a call to the predicate function for type T in Expr if T - -- has predicates and Predicate_Function (T) is non-empty. + else + raise Non_Static; + end if; - procedure Add_Predicates; - -- Appends expressions for any Predicate pragmas in the rep item chain - -- Typ to Expr. Note that we look only at items for this exact entity. - -- Inheritance of predicates for the parent type is done by calling the - -- Predicate_Function of the parent type, using Add_Call above. + -- Construct range according to comparison operation - function Test_RE (N : Node_Id) return Traverse_Result; - -- Used in Test_REs, tests one node for being a raise expression, and if - -- so sets Raise_Expression_Present True. + case Op is + when N_Op_Eq => + return RList'(1 => REnt'(Val, Val)); - procedure Test_REs is new Traverse_Proc (Test_RE); - -- Tests to see if Expr contains any raise expressions + when N_Op_Ge => + return RList'(1 => REnt'(Val, BHi)); - function Process_RE (N : Node_Id) return Traverse_Result; - -- Used in Process REs, tests if node N is a raise expression, and if - -- so, marks it to be converted to return False. + when N_Op_Gt => + return RList'(1 => REnt'(Val + 1, BHi)); - procedure Process_REs is new Traverse_Proc (Process_RE); - -- Marks any raise expressions in Expr_M to return False + when N_Op_Le => + return RList'(1 => REnt'(BLo, Val)); - -------------- - -- Add_Call -- - -------------- + when N_Op_Lt => + return RList'(1 => REnt'(BLo, Val - 1)); - procedure Add_Call (T : Entity_Id) is - Exp : Node_Id; + when N_Op_Ne => + return RList'(REnt'(BLo, Val - 1), REnt'(Val + 1, BHi)); - begin - if Present (T) and then Present (Predicate_Function (T)) then - Set_Has_Predicates (Typ); + when others => + raise Program_Error; + end case; - -- Build the call to the predicate function of T + -- Membership (IN) - Exp := - Make_Predicate_Call - (T, Convert_To (T, Make_Identifier (Loc, Object_Name))); - - -- Add call to evolving expression, using AND THEN if needed + when N_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; - if No (Expr) then - Expr := Exp; - else - Expr := - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (Expr), - Right_Opnd => Exp); - end if; + if Present (Right_Opnd (Exp)) then + return Membership_Entry (Right_Opnd (Exp)); + else + return Membership_Entries (First (Alternatives (Exp))); + end if; - -- Output info message on inheritance if required. Note we do not - -- give this information for generic actual types, since it is - -- unwelcome noise in that case in instantiations. We also - -- generally suppress the message in instantiations, and also - -- if it involves internal names. + -- Negative membership (NOT IN) - if Opt.List_Inherited_Aspects - and then not Is_Generic_Actual_Type (Typ) - and then Instantiation_Depth (Sloc (Typ)) = 0 - and then not Is_Internal_Name (Chars (T)) - and then not Is_Internal_Name (Chars (Typ)) - then - Error_Msg_Sloc := Sloc (Predicate_Function (T)); - Error_Msg_Node_2 := T; - Error_Msg_N ("info: & inherits predicate from & #?L?", Typ); - end if; - end if; - end Add_Call; + when N_Not_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; - -------------------- - -- Add_Predicates -- - -------------------- + if Present (Right_Opnd (Exp)) then + return not Membership_Entry (Right_Opnd (Exp)); + else + return not Membership_Entries (First (Alternatives (Exp))); + end if; - procedure Add_Predicates is - Ritem : Node_Id; - Arg1 : Node_Id; - Arg2 : Node_Id; + -- Function call, may be call to static predicate - procedure Replace_Type_Reference (N : Node_Id); - -- Replace a single occurrence N of the subtype name with a reference - -- to the formal of the predicate function. N can be an identifier - -- referencing the subtype, or a selected component, representing an - -- appropriately qualified occurrence of the subtype name. + when N_Function_Call => + if Is_Entity_Name (Name (Exp)) then + declare + Ent : constant Entity_Id := Entity (Name (Exp)); + begin + if Is_Predicate_Function (Ent) + or else + Is_Predicate_Function_M (Ent) + then + return Stat_Pred (Etype (First_Formal (Ent))); + end if; + end; + end if; - procedure Replace_Type_References is - new Replace_Type_References_Generic (Replace_Type_Reference); - -- Traverse an expression changing every occurrence of an identifier - -- whose name matches the name of the subtype with a reference to - -- the formal parameter of the predicate function. + -- Other function call cases are non-static - ---------------------------- - -- Replace_Type_Reference -- - ---------------------------- + raise Non_Static; - procedure Replace_Type_Reference (N : Node_Id) is - begin - Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); - -- Use the Sloc of the usage name, not the defining name + -- Qualified expression, dig out the expression - Set_Etype (N, Typ); - Set_Entity (N, Object_Entity); + when N_Qualified_Expression => + return Get_RList (Expression (Exp)); - -- We want to treat the node as if it comes from source, so that - -- ASIS will not ignore it + when N_Case_Expression => + declare + Alt : Node_Id; + Choices : List_Id; + Dep : Node_Id; - Set_Comes_From_Source (N, True); - end Replace_Type_Reference; + begin + if not Is_Entity_Name (Expression (Expr)) + or else Etype (Expression (Expr)) /= Typ + then + Error_Msg_N + ("expression must denaote subtype", Expression (Expr)); + return False_Range; + end if; - -- Start of processing for Add_Predicates + -- Collect discrete choices in all True alternatives - begin - Ritem := First_Rep_Item (Typ); - while Present (Ritem) loop - if Nkind (Ritem) = N_Pragma - and then Pragma_Name (Ritem) = Name_Predicate - then - -- Save the static predicate of the type for diagnostics and - -- error reporting purposes. + Choices := New_List; + Alt := First (Alternatives (Exp)); + while Present (Alt) loop + Dep := Expression (Alt); - if Present (Corresponding_Aspect (Ritem)) - and then Chars (Identifier (Corresponding_Aspect (Ritem))) = - Name_Static_Predicate - then - Static_Predic := Ritem; - end if; + if not Is_Static_Expression (Dep) then + raise Non_Static; - -- Acquire arguments + elsif Is_True (Expr_Value (Dep)) then + Append_List_To (Choices, + New_Copy_List (Discrete_Choices (Alt))); + end if; - Arg1 := First (Pragma_Argument_Associations (Ritem)); - Arg2 := Next (Arg1); + Next (Alt); + end loop; - Arg1 := Get_Pragma_Arg (Arg1); - Arg2 := Get_Pragma_Arg (Arg2); + return Membership_Entries (First (Choices)); + end; - -- See if this predicate pragma is for the current type or for - -- its full view. A predicate on a private completion is placed - -- on the partial view beause this is the visible entity that - -- is frozen. + -- Expression with actions: if no actions, dig out expression - if Entity (Arg1) = Typ - or else Full_View (Entity (Arg1)) = Typ - then - -- We have a match, this entry is for our subtype + when N_Expression_With_Actions => + if Is_Empty_List (Actions (Exp)) then + return Get_RList (Expression (Exp)); + else + raise Non_Static; + end if; - -- We need to replace any occurrences of the name of the - -- type with references to the object. + -- Xor operator - Replace_Type_References (Arg2, Chars (Typ)); + when N_Op_Xor => + return (Get_RList (Left_Opnd (Exp)) + and not Get_RList (Right_Opnd (Exp))) + or (Get_RList (Right_Opnd (Exp)) + and not Get_RList (Left_Opnd (Exp))); - -- If this predicate comes from an aspect, find the aspect - -- specification, and replace the saved expression because - -- we need the subtype references replaced for the calls to - -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point - -- and Check_Aspect_At_End_Of_Declarations. + -- Any other node type is non-static - if From_Aspect_Specification (Ritem) then - declare - Aitem : Node_Id; + when others => + raise Non_Static; + end case; + end Get_RList; - begin - -- Loop to find corresponding aspect, note that this - -- must be present given the pragma is marked delayed. + ------------ + -- Hi_Val -- + ------------ - Aitem := Next_Rep_Item (Ritem); - loop - if Nkind (Aitem) = N_Aspect_Specification - and then Aspect_Rep_Item (Aitem) = Ritem - then - Set_Entity - (Identifier (Aitem), New_Copy_Tree (Arg2)); - exit; - end if; + function Hi_Val (N : Node_Id) return Uint is + begin + if Is_Static_Expression (N) then + return Expr_Value (N); + else + pragma Assert (Nkind (N) = N_Range); + return Expr_Value (High_Bound (N)); + end if; + end Hi_Val; - Aitem := Next_Rep_Item (Aitem); - end loop; - end; - end if; + -------------- + -- Is_False -- + -------------- - -- Now we can add the expression + function Is_False (R : RList) return Boolean is + begin + return R'Length = 0; + end Is_False; - if No (Expr) then - Expr := Relocate_Node (Arg2); + ------------- + -- Is_True -- + ------------- - -- There already was a predicate, so add to it + function Is_True (R : RList) return Boolean is + begin + return R'Length = 1 + and then R (R'First).Lo = BLo + and then R (R'First).Hi = BHi; + end Is_True; - else - Expr := - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (Expr), - Right_Opnd => Relocate_Node (Arg2)); - end if; - end if; - end if; + ----------------- + -- Is_Type_Ref -- + ----------------- - Next_Rep_Item (Ritem); - end loop; - end Add_Predicates; + function Is_Type_Ref (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Identifier and then Chars (N) = Nam; + end Is_Type_Ref; - ---------------- - -- Process_RE -- - ---------------- + ------------ + -- Lo_Val -- + ------------ - function Process_RE (N : Node_Id) return Traverse_Result is + function Lo_Val (N : Node_Id) return Uint is begin - if Nkind (N) = N_Raise_Expression then - Set_Convert_To_Return_False (N); - return Skip; + if Is_Static_Expression (N) then + return Expr_Value (N); else - return OK; + pragma Assert (Nkind (N) = N_Range); + return Expr_Value (Low_Bound (N)); end if; - end Process_RE; + end Lo_Val; - ------------- - -- Test_RE -- - ------------- + ------------------------ + -- Membership_Entries -- + ------------------------ - function Test_RE (N : Node_Id) return Traverse_Result is + function Membership_Entries (N : Node_Id) return RList is begin - if Nkind (N) = N_Raise_Expression then - Raise_Expression_Present := True; - return Abandon; + if No (Next (N)) then + return Membership_Entry (N); else - return OK; + return Membership_Entry (N) or Membership_Entries (Next (N)); end if; - end Test_RE; + end Membership_Entries; - -- Start of processing for Build_Predicate_Functions + ---------------------- + -- Membership_Entry -- + ---------------------- - begin - -- Return if already built or if type does not have predicates + function Membership_Entry (N : Node_Id) return RList is + Val : Uint; + SLo : Uint; + SHi : Uint; - if not Has_Predicates (Typ) - or else Present (Predicate_Function (Typ)) - then - return; - end if; + begin + -- Range case - -- Prepare to construct predicate expression + if Nkind (N) = N_Range then + if not Is_Static_Expression (Low_Bound (N)) + or else + not Is_Static_Expression (High_Bound (N)) + then + raise Non_Static; + else + SLo := Expr_Value (Low_Bound (N)); + SHi := Expr_Value (High_Bound (N)); + return RList'(1 => REnt'(SLo, SHi)); + end if; - Expr := Empty; + -- Static expression case - -- Add Predicates for the current type + elsif Is_Static_Expression (N) then + Val := Expr_Value (N); + return RList'(1 => REnt'(Val, Val)); - Add_Predicates; + -- Identifier (other than static expression) case - -- Add predicates for ancestor if present + else pragma Assert (Nkind (N) = N_Identifier); - declare - Atyp : constant Entity_Id := Nearest_Ancestor (Typ); - begin - if Present (Atyp) then - Add_Call (Atyp); - end if; - end; + -- Type case - -- Case where predicates are present + if Is_Type (Entity (N)) then - if Present (Expr) then + -- If type has predicates, process them - -- Test for raise expression present + if Has_Predicates (Entity (N)) then + return Stat_Pred (Entity (N)); - Test_REs (Expr); + -- For static subtype without predicates, get range - -- If raise expression is present, capture a copy of Expr for use - -- in building the predicateM function version later on. For this - -- copy we replace references to Object_Entity by Object_Entity_M. + elsif Is_Static_Subtype (Entity (N)) then + SLo := Expr_Value (Type_Low_Bound (Entity (N))); + SHi := Expr_Value (Type_High_Bound (Entity (N))); + return RList'(1 => REnt'(SLo, SHi)); - if Raise_Expression_Present then - declare - Map : constant Elist_Id := New_Elmt_List; - begin - Append_Elmt (Object_Entity, Map); - Append_Elmt (Object_Entity_M, Map); - Expr_M := New_Copy_Tree (Expr, Map => Map); - end; - end if; + -- Any other type makes us non-static - -- Build the main predicate function + else + raise Non_Static; + end if; - declare - SId : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - -- The entity for the the function spec + -- Any other kind of identifier in predicate (e.g. a non-static + -- expression value) means this is not a static predicate. - SIdB : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - -- The entity for the function body + else + raise Non_Static; + end if; + end if; + end Membership_Entry; - Spec : Node_Id; - FDecl : Node_Id; - FBody : Node_Id; + --------------- + -- Stat_Pred -- + --------------- - begin - -- Build function declaration + function Stat_Pred (Typ : Entity_Id) return RList is + begin + -- Not static if type does not have static predicates - Set_Ekind (SId, E_Function); - Set_Is_Internal (SId); - Set_Is_Predicate_Function (SId); - Set_Predicate_Function (Typ, SId); + if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then + raise Non_Static; + end if; - -- The predicate function is shared between views of a type + -- Otherwise we convert the predicate list to a range list - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Set_Predicate_Function (Full_View (Typ), SId); - end if; + declare + Result : RList (1 .. List_Length (Static_Predicate (Typ))); + P : Node_Id; - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity, - Parameter_Type => New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); + begin + P := First (Static_Predicate (Typ)); + for J in Result'Range loop + Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); + Next (P); + end loop; - FDecl := - Make_Subprogram_Declaration (Loc, - Specification => Spec); + return Result; + end; + end Stat_Pred; - -- Build function body + -- Start of processing for Build_Discrete_Static_Predicate - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SIdB, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Object_Name), - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); + begin + -- Analyze the expression to see if it is a static predicate - FBody := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Expr)))); + declare + Ranges : constant RList := Get_RList (Expr); + -- Range list from expression if it is static - -- Insert declaration before freeze node and body after + Plist : List_Id; - Insert_Before_And_Analyze (N, FDecl); - Insert_After_And_Analyze (N, FBody); - end; + begin + -- Convert range list into a form for the static predicate. In the + -- Ranges array, we just have raw ranges, these must be converted + -- to properly typed and analyzed static expressions or range nodes. - -- Test for raise expressions present and if so build M version + -- Note: here we limit ranges to the ranges of the subtype, so that + -- a predicate is always false for values outside the subtype. That + -- seems fine, such values are invalid anyway, and considering them + -- to fail the predicate seems allowed and friendly, and furthermore + -- simplifies processing for case statements and loops. - if Raise_Expression_Present then + Plist := New_List; + + for J in Ranges'Range loop declare - SId : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "PredicateM")); - -- The entity for the the function spec + Lo : Uint := Ranges (J).Lo; + Hi : Uint := Ranges (J).Hi; - SIdB : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "PredicateM")); - -- The entity for the function body + begin + -- Ignore completely out of range entry - Spec : Node_Id; - FDecl : Node_Id; - FBody : Node_Id; - BTemp : Entity_Id; + if Hi < TLo or else Lo > THi then + null; - begin - -- Mark any raise expressions for special expansion + -- Otherwise process entry - Process_REs (Expr_M); + else + -- Adjust out of range value to subtype range - -- Build function declaration + if Lo < TLo then + Lo := TLo; + end if; - Set_Ekind (SId, E_Function); - Set_Is_Predicate_Function_M (SId); - Set_Predicate_Function_M (Typ, SId); + if Hi > THi then + Hi := THi; + end if; - -- The predicate function is shared between views of a type + -- Convert range into required form - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Set_Predicate_Function_M (Full_View (Typ), SId); + Append_To (Plist, Build_Range (Lo, Hi)); end if; + end; + end loop; - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity_M, - Parameter_Type => New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); + -- Processing was successful and all entries were static, so now we + -- can store the result as the predicate list. - FDecl := - Make_Subprogram_Declaration (Loc, - Specification => Spec); + Set_Static_Predicate (Typ, Plist); - -- Build function body + -- The processing for static predicates put the expression into + -- canonical form as a series of ranges. It also eliminated + -- duplicates and collapsed and combined ranges. We might as well + -- replace the alternatives list of the right operand of the + -- membership test with the static predicate list, which will + -- usually be more efficient. - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SIdB, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Object_Name), - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); + declare + New_Alts : constant List_Id := New_List; + Old_Node : Node_Id; + New_Node : Node_Id; - -- Build the body, we declare the boolean expression before - -- doing the return, because we are not really confident of - -- what happens if a return appears within a return. + begin + Old_Node := First (Plist); + while Present (Old_Node) loop + New_Node := New_Copy (Old_Node); - BTemp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('B')); + if Nkind (New_Node) = N_Range then + Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); + Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); + end if; - FBody := - Make_Subprogram_Body (Loc, - Specification => Spec, + Append_To (New_Alts, New_Node); + Next (Old_Node); + end loop; - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => BTemp, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc), - Expression => Expr_M)), + -- If empty list, replace by False - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (BTemp, Loc))))); + if Is_Empty_List (New_Alts) then + Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); - -- Insert declaration before freeze node and body after + -- Else replace by set membership test - Insert_Before_And_Analyze (N, FDecl); - Insert_After_And_Analyze (N, FBody); - end; - end if; + else + Rewrite (Expr, + Make_In (Loc, + Left_Opnd => Make_Identifier (Loc, Nam), + Right_Opnd => Empty, + Alternatives => New_Alts)); - if Is_Scalar_Type (Typ) then + -- Resolve new expression in function context - -- Attempt to build a static predicate for a discrete or a real - -- subtype. This action may fail because the actual expression may - -- not be static. Note that the presence of an inherited or - -- explicitly declared dynamic predicate is orthogonal to this - -- check because we are only interested in the static predicate. + Install_Formals (Predicate_Function (Typ)); + Push_Scope (Predicate_Function (Typ)); + Analyze_And_Resolve (Expr, Standard_Boolean); + Pop_Scope; + end if; + end; + end; - if Ekind_In (Typ, E_Decimal_Fixed_Point_Subtype, - E_Enumeration_Subtype, - E_Floating_Point_Subtype, - E_Modular_Integer_Subtype, - E_Ordinary_Fixed_Point_Subtype, - E_Signed_Integer_Subtype) - then - Build_Static_Predicate (Typ, Expr, Object_Name); + -- If non-static, return doing nothing - -- Emit an error when the predicate is categorized as static - -- but its expression is dynamic. + exception + when Non_Static => + return; + end Build_Discrete_Static_Predicate; - if Present (Static_Predic) - and then No (Static_Predicate (Typ)) - then - Error_Msg_F - ("expression does not have required form for " - & "static predicate", - Next (First (Pragma_Argument_Associations - (Static_Predic)))); - end if; - end if; + ------------------------------------------- + -- Build_Invariant_Procedure_Declaration -- + ------------------------------------------- - -- If a static predicate applies on other types, that's an error: - -- either the type is scalar but non-static, or it's not even a - -- scalar type. We do not issue an error on generated types, as - -- these may be duplicates of the same error on a source type. + function Build_Invariant_Procedure_Declaration + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Object_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + Spec : Node_Id; + SId : Entity_Id; - elsif Present (Static_Predic) and then Comes_From_Source (Typ) then - if Is_Scalar_Type (Typ) then - Error_Msg_FE - ("static predicate not allowed for non-static type&", - Typ, Typ); - else - Error_Msg_FE - ("static predicate not allowed for non-scalar type&", - Typ, Typ); - end if; - end if; + begin + Set_Etype (Object_Entity, Typ); + + -- Check for duplicate definiations. + + if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then + return Empty; end if; - end Build_Predicate_Functions; - ---------------------------- - -- Build_Static_Predicate -- - ---------------------------- + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Invariant")); + Set_Has_Invariants (Typ); + Set_Ekind (SId, E_Procedure); + Set_Is_Invariant_Procedure (SId); + Set_Invariant_Procedure (Typ, SId); - procedure Build_Static_Predicate - (Typ : Entity_Id; - Expr : Node_Id; - Nam : Name_Id) - is - Loc : constant Source_Ptr := Sloc (Expr); + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (Typ, Loc)))); - Non_Static : exception; - -- Raised if something non-static is found + return Make_Subprogram_Declaration (Loc, Specification => Spec); + end Build_Invariant_Procedure_Declaration; + + ------------------------------- + -- Build_Invariant_Procedure -- + ------------------------------- + + -- The procedure that is constructed here has the form + + -- procedure typInvariant (Ixxx : typ) is + -- begin + -- pragma Check (Invariant, exp, "failed invariant from xxx"); + -- pragma Check (Invariant, exp, "failed invariant from xxx"); + -- ... + -- pragma Check (Invariant, exp, "failed inherited invariant from xxx"); + -- ... + -- end typInvariant; + + procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Stmts : List_Id; + Spec : Node_Id; + SId : Entity_Id; + PDecl : Node_Id; + PBody : Node_Id; - Btyp : constant Entity_Id := Base_Type (Typ); + Nam : Name_Id; + -- Name for Check pragma, usually Invariant, but might be Type_Invariant + -- if we come from a Type_Invariant aspect, we make sure to build the + -- Check pragma with the right name, so that Check_Policy works right. - BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp)); - BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp)); - -- Low bound and high bound value of base type of Typ + Visible_Decls : constant List_Id := Visible_Declarations (N); + Private_Decls : constant List_Id := Private_Declarations (N); - TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ)); - THi : constant Uint := Expr_Value (Type_High_Bound (Typ)); - -- Low bound and high bound values of static subtype Typ + procedure Add_Invariants (T : Entity_Id; Inherit : Boolean); + -- Appends statements to Stmts for any invariants in the rep item chain + -- of the given type. If Inherit is False, then we only process entries + -- on the chain for the type Typ. If Inherit is True, then we ignore any + -- Invariant aspects, but we process all Invariant'Class aspects, adding + -- "inherited" to the exception message and generating an informational + -- message about the inheritance of an invariant. - type REnt is record - Lo, Hi : Uint; - end record; - -- One entry in a Rlist value, a single REnt (range entry) value denotes - -- one range from Lo to Hi. To represent a single value range Lo = Hi = - -- value. + Object_Name : Name_Id; + -- Name for argument of invariant procedure - type RList is array (Nat range <>) of REnt; - -- A list of ranges. The ranges are sorted in increasing order, and are - -- disjoint (there is a gap of at least one value between each range in - -- the table). A value is in the set of ranges in Rlist if it lies - -- within one of these ranges. + Object_Entity : Node_Id; + -- The entity of the formal for the procedure - False_Range : constant RList := - RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); - -- An empty set of ranges represents a range list that can never be - -- satisfied, since there are no ranges in which the value could lie, - -- so it does not lie in any of them. False_Range is a canonical value - -- for this empty set, but general processing should test for an Rlist - -- with length zero (see Is_False predicate), since other null ranges - -- may appear which must be treated as False. + -------------------- + -- Add_Invariants -- + -------------------- - True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); - -- Range representing True, value must be in the base range + procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is + Ritem : Node_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; + Arg3 : Node_Id; + Exp : Node_Id; + Loc : Source_Ptr; + Assoc : List_Id; + Str : String_Id; - function "and" (Left : RList; Right : RList) return RList; - -- And's together two range lists, returning a range list. This is a set - -- intersection operation. + procedure Replace_Type_Reference (N : Node_Id); + -- Replace a single occurrence N of the subtype name with a reference + -- to the formal of the predicate function. N can be an identifier + -- referencing the subtype, or a selected component, representing an + -- appropriately qualified occurrence of the subtype name. - function "or" (Left : RList; Right : RList) return RList; - -- Or's together two range lists, returning a range list. This is a set - -- union operation. + procedure Replace_Type_References is + new Replace_Type_References_Generic (Replace_Type_Reference); + -- Traverse an expression replacing all occurrences of the subtype + -- name with appropriate references to the object that is the formal + -- parameter of the predicate function. Note that we must ensure + -- that the type and entity information is properly set in the + -- replacement node, since we will do a Preanalyze call of this + -- expression without proper visibility of the procedure argument. - function "not" (Right : RList) return RList; - -- Returns complement of a given range list, i.e. a range list - -- representing all the values in TLo .. THi that are not in the input - -- operand Right. + ---------------------------- + -- Replace_Type_Reference -- + ---------------------------- - function Build_Val (V : Uint) return Node_Id; - -- Return an analyzed N_Identifier node referencing this value, suitable - -- for use as an entry in the Static_Predicate list. This node is typed - -- with the base type. + -- Note: See comments in Add_Predicates.Replace_Type_Reference + -- regarding handling of Sloc and Comes_From_Source. - function Build_Range (Lo : Uint; Hi : Uint) return Node_Id; - -- Return an analyzed N_Range node referencing this range, suitable for - -- use as an entry in the Static_Predicate list. This node is typed with - -- the base type. + procedure Replace_Type_Reference (N : Node_Id) is + begin - function Get_RList (Exp : Node_Id) return RList; - -- This is a recursive routine that converts the given expression into a - -- list of ranges, suitable for use in building the static predicate. + -- Add semantic information to node to be rewritten, for ASIS + -- navigation needs. - function Is_False (R : RList) return Boolean; - pragma Inline (Is_False); - -- Returns True if the given range list is empty, and thus represents a - -- False list of ranges that can never be satisfied. + if Nkind (N) = N_Identifier then + Set_Entity (N, T); + Set_Etype (N, T); - function Is_True (R : RList) return Boolean; - -- Returns True if R trivially represents the True predicate by having a - -- single range from BLo to BHi. + elsif Nkind (N) = N_Selected_Component then + Analyze (Prefix (N)); + Set_Entity (Selector_Name (N), T); + Set_Etype (Selector_Name (N), T); + end if; - function Is_Type_Ref (N : Node_Id) return Boolean; - pragma Inline (Is_Type_Ref); - -- Returns if True if N is a reference to the type for the predicate in - -- the expression (i.e. if it is an identifier whose Chars field matches - -- the Nam given in the call). + -- Invariant'Class, replace with T'Class (obj) - function Lo_Val (N : Node_Id) return Uint; - -- Given static expression or static range from a Static_Predicate list, - -- gets expression value or low bound of range. + if Class_Present (Ritem) then + Rewrite (N, + Make_Type_Conversion (Sloc (N), + Subtype_Mark => + Make_Attribute_Reference (Sloc (N), + Prefix => New_Occurrence_Of (T, Sloc (N)), + Attribute_Name => Name_Class), + Expression => Make_Identifier (Sloc (N), Object_Name))); - function Hi_Val (N : Node_Id) return Uint; - -- Given static expression or static range from a Static_Predicate list, - -- gets expression value of high bound of range. + Set_Entity (Expression (N), Object_Entity); + Set_Etype (Expression (N), Typ); - function Membership_Entry (N : Node_Id) return RList; - -- Given a single membership entry (range, value, or subtype), returns - -- the corresponding range list. Raises Static_Error if not static. + -- Invariant, replace with obj - function Membership_Entries (N : Node_Id) return RList; - -- Given an element on an alternatives list of a membership operation, - -- returns the range list corresponding to this entry and all following - -- entries (i.e. returns the "or" of this list of values). + else + Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); + Set_Entity (N, Object_Entity); + Set_Etype (N, Typ); + end if; - function Stat_Pred (Typ : Entity_Id) return RList; - -- Given a type, if it has a static predicate, then return the predicate - -- as a range list, otherwise raise Non_Static. + Set_Comes_From_Source (N, True); + end Replace_Type_Reference; - ----------- - -- "and" -- - ----------- + -- Start of processing for Add_Invariants - function "and" (Left : RList; Right : RList) return RList is - FEnt : REnt; - -- First range of result + begin + Ritem := First_Rep_Item (T); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Invariant + then + Arg1 := First (Pragma_Argument_Associations (Ritem)); + Arg2 := Next (Arg1); + Arg3 := Next (Arg2); - SLeft : Nat := Left'First; - -- Start of rest of left entries + Arg1 := Get_Pragma_Arg (Arg1); + Arg2 := Get_Pragma_Arg (Arg2); - SRight : Nat := Right'First; - -- Start of rest of right entries + -- For Inherit case, ignore Invariant, process only Class case - begin - -- If either range is True, return the other + if Inherit then + if not Class_Present (Ritem) then + goto Continue; + end if; - if Is_True (Left) then - return Right; - elsif Is_True (Right) then - return Left; - end if; + -- For Inherit false, process only item for right type - -- If either range is False, return False + else + if Entity (Arg1) /= Typ then + goto Continue; + end if; + end if; - if Is_False (Left) or else Is_False (Right) then - return False_Range; - end if; + if No (Stmts) then + Stmts := Empty_List; + end if; - -- Loop to remove entries at start that are disjoint, and thus just - -- get discarded from the result entirely. + Exp := New_Copy_Tree (Arg2); - loop - -- If no operands left in either operand, result is false + -- Preserve sloc of original pragma Invariant - if SLeft > Left'Last or else SRight > Right'Last then - return False_Range; + Loc := Sloc (Ritem); - -- Discard first left operand entry if disjoint with right + -- We need to replace any occurrences of the name of the type + -- with references to the object, converted to type'Class in + -- the case of Invariant'Class aspects. - elsif Left (SLeft).Hi < Right (SRight).Lo then - SLeft := SLeft + 1; + Replace_Type_References (Exp, Chars (T)); - -- Discard first right operand entry if disjoint with left + -- If this invariant comes from an aspect, find the aspect + -- specification, and replace the saved expression because + -- we need the subtype references replaced for the calls to + -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point + -- and Check_Aspect_At_End_Of_Declarations. - elsif Right (SRight).Hi < Left (SLeft).Lo then - SRight := SRight + 1; + if From_Aspect_Specification (Ritem) then + declare + Aitem : Node_Id; - -- Otherwise we have an overlapping entry + begin + -- Loop to find corresponding aspect, note that this + -- must be present given the pragma is marked delayed. - else - exit; - end if; - end loop; + -- Note: in practice Next_Rep_Item (Ritem) is Empty so + -- this loop does nothing. Furthermore, why isn't this + -- simply Corresponding_Aspect ??? - -- Now we have two non-null operands, and first entries overlap. The - -- first entry in the result will be the overlapping part of these - -- two entries. + Aitem := Next_Rep_Item (Ritem); + while Present (Aitem) loop + if Nkind (Aitem) = N_Aspect_Specification + and then Aspect_Rep_Item (Aitem) = Ritem + then + Set_Entity + (Identifier (Aitem), New_Copy_Tree (Exp)); + exit; + end if; - FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), - Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); + Aitem := Next_Rep_Item (Aitem); + end loop; + end; + end if; - -- Now we can remove the entry that ended at a lower value, since its - -- contribution is entirely contained in Fent. + -- Now we need to preanalyze the expression to properly capture + -- the visibility in the visible part. The expression will not + -- be analyzed for real until the body is analyzed, but that is + -- at the end of the private part and has the wrong visibility. - if Left (SLeft).Hi <= Right (SRight).Hi then - SLeft := SLeft + 1; - else - SRight := SRight + 1; - end if; + Set_Parent (Exp, N); + Preanalyze_Assert_Expression (Exp, Standard_Boolean); - -- Compute result by concatenating this first entry with the "and" of - -- the remaining parts of the left and right operands. Note that if - -- either of these is empty, "and" will yield empty, so that we will - -- end up with just Fent, which is what we want in that case. + -- In ASIS mode, even if assertions are not enabled, we must + -- analyze the original expression in the aspect specification + -- because it is part of the original tree. - return - FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); - end "and"; + if ASIS_Mode and then From_Aspect_Specification (Ritem) then + declare + Inv : constant Node_Id := + Expression (Corresponding_Aspect (Ritem)); + begin + Replace_Type_References (Inv, Chars (T)); + Preanalyze_Assert_Expression (Inv, Standard_Boolean); + end; + end if; - ----------- - -- "not" -- - ----------- + -- Get name to be used for Check pragma - function "not" (Right : RList) return RList is - begin - -- Return True if False range + if not From_Aspect_Specification (Ritem) then + Nam := Name_Invariant; + else + Nam := Chars (Identifier (Corresponding_Aspect (Ritem))); + end if; - if Is_False (Right) then - return True_Range; - end if; + -- Build first two arguments for Check pragma - -- Return False if True range + Assoc := + New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Chars => Nam)), + Make_Pragma_Argument_Association (Loc, + Expression => Exp)); - if Is_True (Right) then - return False_Range; - end if; + -- Add message if present in Invariant pragma - -- Here if not trivial case + if Present (Arg3) then + Str := Strval (Get_Pragma_Arg (Arg3)); - declare - Result : RList (1 .. Right'Length + 1); - -- May need one more entry for gap at beginning and end + -- If inherited case, and message starts "failed invariant", + -- change it to be "failed inherited invariant". - Count : Nat := 0; - -- Number of entries stored in Result + if Inherit then + String_To_Name_Buffer (Str); - begin - -- Gap at start + if Name_Buffer (1 .. 16) = "failed invariant" then + Insert_Str_In_Name_Buffer ("inherited ", 8); + Str := String_From_Name_Buffer; + end if; + end if; - if Right (Right'First).Lo > TLo then - Count := Count + 1; - Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); - end if; + Append_To (Assoc, + Make_Pragma_Argument_Association (Loc, + Expression => Make_String_Literal (Loc, Str))); + end if; - -- Gaps between ranges + -- Add Check pragma to list of statements - for J in Right'First .. Right'Last - 1 loop - Count := Count + 1; - Result (Count) := - REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); - end loop; + Append_To (Stmts, + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Loc, Name_Check), + Pragma_Argument_Associations => Assoc)); - -- Gap at end + -- If Inherited case and option enabled, output info msg. Note + -- that we know this is a case of Invariant'Class. - if Right (Right'Last).Hi < THi then - Count := Count + 1; - Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); + if Inherit and Opt.List_Inherited_Aspects then + Error_Msg_Sloc := Sloc (Ritem); + Error_Msg_N + ("info: & inherits `Invariant''Class` aspect from #?L?", + Typ); + end if; end if; - return Result (1 .. Count); - end; - end "not"; + <> + Next_Rep_Item (Ritem); + end loop; + end Add_Invariants; - ---------- - -- "or" -- - ---------- + -- Start of processing for Build_Invariant_Procedure - function "or" (Left : RList; Right : RList) return RList is - FEnt : REnt; - -- First range of result + begin + Stmts := No_List; + PDecl := Empty; + PBody := Empty; + SId := Empty; - SLeft : Nat := Left'First; - -- Start of rest of left entries + -- If the aspect specification exists for some view of the type, the + -- declaration for the procedure has been created. - SRight : Nat := Right'First; - -- Start of rest of right entries + if Has_Invariants (Typ) then + SId := Invariant_Procedure (Typ); + end if; - begin - -- If either range is True, return True + if Present (SId) then + PDecl := Unit_Declaration_Node (SId); + else + PDecl := Build_Invariant_Procedure_Declaration (Typ); + end if; - if Is_True (Left) or else Is_True (Right) then - return True_Range; - end if; + -- Recover formal of procedure, for use in the calls to invariant + -- functions (including inherited ones). - -- If either range is False (empty), return the other + Object_Entity := + Defining_Identifier + (First (Parameter_Specifications (Specification (PDecl)))); + Object_Name := Chars (Object_Entity); - if Is_False (Left) then - return Right; - elsif Is_False (Right) then - return Left; - end if; + -- Add invariants for the current type - -- Initialize result first entry from left or right operand depending - -- on which starts with the lower range. + Add_Invariants (Typ, Inherit => False); - if Left (SLeft).Lo < Right (SRight).Lo then - FEnt := Left (SLeft); - SLeft := SLeft + 1; - else - FEnt := Right (SRight); - SRight := SRight + 1; - end if; + -- Add invariants for parent types - -- This loop eats ranges from left and right operands that are - -- contiguous with the first range we are gathering. + declare + Current_Typ : Entity_Id; + Parent_Typ : Entity_Id; + begin + Current_Typ := Typ; loop - -- Eat first entry in left operand if contiguous or overlapped by - -- gathered first operand of result. + Parent_Typ := Etype (Current_Typ); - if SLeft <= Left'Last - and then Left (SLeft).Lo <= FEnt.Hi + 1 + if Is_Private_Type (Parent_Typ) + and then Present (Full_View (Base_Type (Parent_Typ))) then - FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); - SLeft := SLeft + 1; + Parent_Typ := Full_View (Base_Type (Parent_Typ)); + end if; - -- Eat first entry in right operand if contiguous or overlapped by - -- gathered right operand of result. + exit when Parent_Typ = Current_Typ; - elsif SRight <= Right'Last - and then Right (SRight).Lo <= FEnt.Hi + 1 - then - FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); - SRight := SRight + 1; + Current_Typ := Parent_Typ; + Add_Invariants (Current_Typ, Inherit => True); + end loop; + end; - -- All done if no more entries to eat + -- Build the procedure if we generated at least one Check pragma - else - exit; - end if; - end loop; + if Stmts /= No_List then + Spec := Copy_Separate_Tree (Specification (PDecl)); - -- Obtain result as the first entry we just computed, concatenated - -- to the "or" of the remaining results (if one operand is empty, - -- this will just concatenate with the other + PBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); - return - FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); - end "or"; + -- Insert procedure declaration and spec at the appropriate points. + -- If declaration is already analyzed, it was processed by the + -- generated pragma. - ----------------- - -- Build_Range -- - ----------------- + if Present (Private_Decls) then - function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is - Result : Node_Id; + -- The spec goes at the end of visible declarations, but they have + -- already been analyzed, so we need to explicitly do the analyze. - begin - Result := - Make_Range (Loc, - Low_Bound => Build_Val (Lo), - High_Bound => Build_Val (Hi)); - Set_Etype (Result, Btyp); - Set_Analyzed (Result); + if not Analyzed (PDecl) then + Append_To (Visible_Decls, PDecl); + Analyze (PDecl); + end if; - return Result; - end Build_Range; + -- The body goes at the end of the private declarations, which we + -- have not analyzed yet, so we do not need to perform an explicit + -- analyze call. We skip this if there are no private declarations + -- (this is an error that will be caught elsewhere); - --------------- - -- Build_Val -- - --------------- + Append_To (Private_Decls, PBody); - function Build_Val (V : Uint) return Node_Id is - Result : Node_Id; + -- If the invariant appears on the full view of a type, the + -- analysis of the private part is complete, and we must + -- analyze the new body explicitly. - begin - if Is_Enumeration_Type (Typ) then - Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); - else - Result := Make_Integer_Literal (Loc, V); - end if; + if In_Private_Part (Current_Scope) then + Analyze (PBody); + end if; - Set_Etype (Result, Btyp); - Set_Is_Static_Expression (Result); - Set_Analyzed (Result); - return Result; - end Build_Val; + -- If there are no private declarations this may be an error that + -- will be diagnosed elsewhere. However, if this is a non-private + -- type that inherits invariants, it needs no completion and there + -- may be no private part. In this case insert invariant procedure + -- at end of current declarative list, and analyze at once, given + -- that the type is about to be frozen. - --------------- - -- Get_RList -- - --------------- + elsif not Is_Private_Type (Typ) then + Append_To (Visible_Decls, PDecl); + Append_To (Visible_Decls, PBody); + Analyze (PDecl); + Analyze (PBody); + end if; + end if; + end Build_Invariant_Procedure; - function Get_RList (Exp : Node_Id) return RList is - Op : Node_Kind; - Val : Uint; + ------------------------------- + -- Build_Predicate_Functions -- + ------------------------------- - begin - -- Static expression can only be true or false + -- The procedures that are constructed here have the form: - if Is_OK_Static_Expression (Exp) then + -- function typPredicate (Ixxx : typ) return Boolean is + -- begin + -- return + -- exp1 and then exp2 and then ... + -- and then typ1Predicate (typ1 (Ixxx)) + -- and then typ2Predicate (typ2 (Ixxx)) + -- and then ...; + -- end typPredicate; - -- For False + -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that + -- this is the point at which these expressions get analyzed, providing the + -- required delay, and typ1, typ2, are entities from which predicates are + -- inherited. Note that we do NOT generate Check pragmas, that's because we + -- use this function even if checks are off, e.g. for membership tests. - if Expr_Value (Exp) = 0 then - return False_Range; - else - return True_Range; - end if; - end if; + -- If the expression has at least one Raise_Expression, then we also build + -- the typPredicateM version of the function, in which any occurrence of a + -- Raise_Expression is converted to "return False". - -- Otherwise test node type + procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Typ); - Op := Nkind (Exp); + Expr : Node_Id; + -- This is the expression for the result of the function. It is + -- is build by connecting the component predicates with AND THEN. - case Op is + Expr_M : Node_Id; + -- This is the corresponding return expression for the Predicate_M + -- function. It differs in that raise expressions are marked for + -- special expansion (see Process_REs). - -- And + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of Predicate procedure. Note that we use the same + -- name for both predicate procedure. That way the reference within the + -- predicate expression is the same in both functions. - when N_Op_And | N_And_Then => - return Get_RList (Left_Opnd (Exp)) - and - Get_RList (Right_Opnd (Exp)); + Object_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Object_Name); + -- Entity for argument of Predicate procedure - -- Or + Object_Entity_M : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Object_Name); + -- Entity for argument of Predicate_M procedure - when N_Op_Or | N_Or_Else => - return Get_RList (Left_Opnd (Exp)) - or - Get_RList (Right_Opnd (Exp)); + Raise_Expression_Present : Boolean := False; + -- Set True if Expr has at least one Raise_Expression - -- Not + Static_Predic : Node_Id := Empty; + -- Set to N_Pragma node for a static predicate if one is encountered - when N_Op_Not => - return not Get_RList (Right_Opnd (Exp)); + procedure Add_Call (T : Entity_Id); + -- Includes a call to the predicate function for type T in Expr if T + -- has predicates and Predicate_Function (T) is non-empty. - -- Comparisons of type with static value + procedure Add_Predicates; + -- Appends expressions for any Predicate pragmas in the rep item chain + -- Typ to Expr. Note that we look only at items for this exact entity. + -- Inheritance of predicates for the parent type is done by calling the + -- Predicate_Function of the parent type, using Add_Call above. - when N_Op_Compare => + function Test_RE (N : Node_Id) return Traverse_Result; + -- Used in Test_REs, tests one node for being a raise expression, and if + -- so sets Raise_Expression_Present True. - -- Type is left operand + procedure Test_REs is new Traverse_Proc (Test_RE); + -- Tests to see if Expr contains any raise expressions - if Is_Type_Ref (Left_Opnd (Exp)) - and then Is_OK_Static_Expression (Right_Opnd (Exp)) - then - Val := Expr_Value (Right_Opnd (Exp)); + function Process_RE (N : Node_Id) return Traverse_Result; + -- Used in Process REs, tests if node N is a raise expression, and if + -- so, marks it to be converted to return False. - -- Typ is right operand + procedure Process_REs is new Traverse_Proc (Process_RE); + -- Marks any raise expressions in Expr_M to return False - elsif Is_Type_Ref (Right_Opnd (Exp)) - and then Is_OK_Static_Expression (Left_Opnd (Exp)) - then - Val := Expr_Value (Left_Opnd (Exp)); + -------------- + -- Add_Call -- + -------------- - -- Invert sense of comparison + procedure Add_Call (T : Entity_Id) is + Exp : Node_Id; - case Op is - when N_Op_Gt => Op := N_Op_Lt; - when N_Op_Lt => Op := N_Op_Gt; - when N_Op_Ge => Op := N_Op_Le; - when N_Op_Le => Op := N_Op_Ge; - when others => null; - end case; + begin + if Present (T) and then Present (Predicate_Function (T)) then + Set_Has_Predicates (Typ); - -- Other cases are non-static + -- Build the call to the predicate function of T - else - raise Non_Static; - end if; + Exp := + Make_Predicate_Call + (T, Convert_To (T, Make_Identifier (Loc, Object_Name))); - -- Construct range according to comparison operation + -- Add call to evolving expression, using AND THEN if needed - case Op is - when N_Op_Eq => - return RList'(1 => REnt'(Val, Val)); + if No (Expr) then + Expr := Exp; + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Exp); + end if; - when N_Op_Ge => - return RList'(1 => REnt'(Val, BHi)); + -- Output info message on inheritance if required. Note we do not + -- give this information for generic actual types, since it is + -- unwelcome noise in that case in instantiations. We also + -- generally suppress the message in instantiations, and also + -- if it involves internal names. - when N_Op_Gt => - return RList'(1 => REnt'(Val + 1, BHi)); + if Opt.List_Inherited_Aspects + and then not Is_Generic_Actual_Type (Typ) + and then Instantiation_Depth (Sloc (Typ)) = 0 + and then not Is_Internal_Name (Chars (T)) + and then not Is_Internal_Name (Chars (Typ)) + then + Error_Msg_Sloc := Sloc (Predicate_Function (T)); + Error_Msg_Node_2 := T; + Error_Msg_N ("info: & inherits predicate from & #?L?", Typ); + end if; + end if; + end Add_Call; - when N_Op_Le => - return RList'(1 => REnt'(BLo, Val)); + -------------------- + -- Add_Predicates -- + -------------------- - when N_Op_Lt => - return RList'(1 => REnt'(BLo, Val - 1)); + procedure Add_Predicates is + Ritem : Node_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; - when N_Op_Ne => - return RList'(REnt'(BLo, Val - 1), - REnt'(Val + 1, BHi)); + procedure Replace_Type_Reference (N : Node_Id); + -- Replace a single occurrence N of the subtype name with a reference + -- to the formal of the predicate function. N can be an identifier + -- referencing the subtype, or a selected component, representing an + -- appropriately qualified occurrence of the subtype name. - when others => - raise Program_Error; - end case; + procedure Replace_Type_References is + new Replace_Type_References_Generic (Replace_Type_Reference); + -- Traverse an expression changing every occurrence of an identifier + -- whose name matches the name of the subtype with a reference to + -- the formal parameter of the predicate function. - -- Membership (IN) + ---------------------------- + -- Replace_Type_Reference -- + ---------------------------- - when N_In => - if not Is_Type_Ref (Left_Opnd (Exp)) then - raise Non_Static; - end if; + procedure Replace_Type_Reference (N : Node_Id) is + begin + Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); + -- Use the Sloc of the usage name, not the defining name - if Present (Right_Opnd (Exp)) then - return Membership_Entry (Right_Opnd (Exp)); - else - return Membership_Entries (First (Alternatives (Exp))); - end if; + Set_Etype (N, Typ); + Set_Entity (N, Object_Entity); - -- Negative membership (NOT IN) + -- We want to treat the node as if it comes from source, so that + -- ASIS will not ignore it - when N_Not_In => - if not Is_Type_Ref (Left_Opnd (Exp)) then - raise Non_Static; - end if; + Set_Comes_From_Source (N, True); + end Replace_Type_Reference; - if Present (Right_Opnd (Exp)) then - return not Membership_Entry (Right_Opnd (Exp)); - else - return not Membership_Entries (First (Alternatives (Exp))); - end if; + -- Start of processing for Add_Predicates - -- Function call, may be call to static predicate + begin + Ritem := First_Rep_Item (Typ); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Predicate + then + -- Save the static predicate of the type for diagnostics and + -- error reporting purposes. - when N_Function_Call => - if Is_Entity_Name (Name (Exp)) then - declare - Ent : constant Entity_Id := Entity (Name (Exp)); - begin - if Is_Predicate_Function (Ent) - or else - Is_Predicate_Function_M (Ent) - then - return Stat_Pred (Etype (First_Formal (Ent))); - end if; - end; + if Present (Corresponding_Aspect (Ritem)) + and then Chars (Identifier (Corresponding_Aspect (Ritem))) = + Name_Static_Predicate + then + Static_Predic := Ritem; end if; - -- Other function call cases are non-static - - raise Non_Static; + -- Acquire arguments - -- Qualified expression, dig out the expression + Arg1 := First (Pragma_Argument_Associations (Ritem)); + Arg2 := Next (Arg1); - when N_Qualified_Expression => - return Get_RList (Expression (Exp)); + Arg1 := Get_Pragma_Arg (Arg1); + Arg2 := Get_Pragma_Arg (Arg2); - when N_Case_Expression => - declare - Alt : Node_Id; - Choices : List_Id; - Dep : Node_Id; + -- See if this predicate pragma is for the current type or for + -- its full view. A predicate on a private completion is placed + -- on the partial view beause this is the visible entity that + -- is frozen. - begin - if not Is_Entity_Name (Expression (Expr)) - or else Etype (Expression (Expr)) /= Typ + if Entity (Arg1) = Typ + or else Full_View (Entity (Arg1)) = Typ then - Error_Msg_N - ("expression must denaote subtype", Expression (Expr)); - return False_Range; - end if; + -- We have a match, this entry is for our subtype - -- Collect discrete choices in all True alternatives + -- We need to replace any occurrences of the name of the + -- type with references to the object. - Choices := New_List; - Alt := First (Alternatives (Exp)); - while Present (Alt) loop - Dep := Expression (Alt); + Replace_Type_References (Arg2, Chars (Typ)); - if not Is_Static_Expression (Dep) then - raise Non_Static; + -- If this predicate comes from an aspect, find the aspect + -- specification, and replace the saved expression because + -- we need the subtype references replaced for the calls to + -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point + -- and Check_Aspect_At_End_Of_Declarations. - elsif Is_True (Expr_Value (Dep)) then - Append_List_To (Choices, - New_Copy_List (Discrete_Choices (Alt))); - end if; + if From_Aspect_Specification (Ritem) then + declare + Aitem : Node_Id; - Next (Alt); - end loop; + begin + -- Loop to find corresponding aspect, note that this + -- must be present given the pragma is marked delayed. - return Membership_Entries (First (Choices)); - end; + Aitem := Next_Rep_Item (Ritem); + loop + if Nkind (Aitem) = N_Aspect_Specification + and then Aspect_Rep_Item (Aitem) = Ritem + then + Set_Entity + (Identifier (Aitem), New_Copy_Tree (Arg2)); + exit; + end if; - -- Expression with actions: if no actions, dig out expression + Aitem := Next_Rep_Item (Aitem); + end loop; + end; + end if; - when N_Expression_With_Actions => - if Is_Empty_List (Actions (Exp)) then - return Get_RList (Expression (Exp)); - else - raise Non_Static; - end if; + -- Now we can add the expression - -- Xor operator + if No (Expr) then + Expr := Relocate_Node (Arg2); - when N_Op_Xor => - return (Get_RList (Left_Opnd (Exp)) - and not Get_RList (Right_Opnd (Exp))) - or (Get_RList (Right_Opnd (Exp)) - and not Get_RList (Left_Opnd (Exp))); + -- There already was a predicate, so add to it - -- Any other node type is non-static + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Relocate_Node (Arg2)); + end if; + end if; + end if; - when others => - raise Non_Static; - end case; - end Get_RList; + Next_Rep_Item (Ritem); + end loop; + end Add_Predicates; - ------------ - -- Hi_Val -- - ------------ + ---------------- + -- Process_RE -- + ---------------- - function Hi_Val (N : Node_Id) return Uint is + function Process_RE (N : Node_Id) return Traverse_Result is begin - if Is_Static_Expression (N) then - return Expr_Value (N); + if Nkind (N) = N_Raise_Expression then + Set_Convert_To_Return_False (N); + return Skip; else - pragma Assert (Nkind (N) = N_Range); - return Expr_Value (High_Bound (N)); + return OK; end if; - end Hi_Val; - - -------------- - -- Is_False -- - -------------- - - function Is_False (R : RList) return Boolean is - begin - return R'Length = 0; - end Is_False; + end Process_RE; ------------- - -- Is_True -- + -- Test_RE -- ------------- - function Is_True (R : RList) return Boolean is + function Test_RE (N : Node_Id) return Traverse_Result is begin - return R'Length = 1 - and then R (R'First).Lo = BLo - and then R (R'First).Hi = BHi; - end Is_True; + if Nkind (N) = N_Raise_Expression then + Raise_Expression_Present := True; + return Abandon; + else + return OK; + end if; + end Test_RE; - ----------------- - -- Is_Type_Ref -- - ----------------- + -- Start of processing for Build_Predicate_Functions - function Is_Type_Ref (N : Node_Id) return Boolean is - begin - return Nkind (N) = N_Identifier and then Chars (N) = Nam; - end Is_Type_Ref; + begin + -- Return if already built or if type does not have predicates - ------------ - -- Lo_Val -- - ------------ + if not Has_Predicates (Typ) + or else Present (Predicate_Function (Typ)) + then + return; + end if; - function Lo_Val (N : Node_Id) return Uint is - begin - if Is_Static_Expression (N) then - return Expr_Value (N); - else - pragma Assert (Nkind (N) = N_Range); - return Expr_Value (Low_Bound (N)); - end if; - end Lo_Val; + -- Prepare to construct predicate expression - ------------------------ - -- Membership_Entries -- - ------------------------ + Expr := Empty; - function Membership_Entries (N : Node_Id) return RList is - begin - if No (Next (N)) then - return Membership_Entry (N); - else - return Membership_Entry (N) or Membership_Entries (Next (N)); - end if; - end Membership_Entries; + -- Add Predicates for the current type - ---------------------- - -- Membership_Entry -- - ---------------------- + Add_Predicates; - function Membership_Entry (N : Node_Id) return RList is - Val : Uint; - SLo : Uint; - SHi : Uint; + -- Add predicates for ancestor if present + declare + Atyp : constant Entity_Id := Nearest_Ancestor (Typ); begin - -- Range case - - if Nkind (N) = N_Range then - if not Is_Static_Expression (Low_Bound (N)) - or else - not Is_Static_Expression (High_Bound (N)) - then - raise Non_Static; - else - SLo := Expr_Value (Low_Bound (N)); - SHi := Expr_Value (High_Bound (N)); - return RList'(1 => REnt'(SLo, SHi)); - end if; + if Present (Atyp) then + Add_Call (Atyp); + end if; + end; - -- Static expression case + -- Case where predicates are present - elsif Is_Static_Expression (N) then - Val := Expr_Value (N); - return RList'(1 => REnt'(Val, Val)); + if Present (Expr) then - -- Identifier (other than static expression) case + -- Test for raise expression present - else pragma Assert (Nkind (N) = N_Identifier); + Test_REs (Expr); - -- Type case + -- If raise expression is present, capture a copy of Expr for use + -- in building the predicateM function version later on. For this + -- copy we replace references to Object_Entity by Object_Entity_M. - if Is_Type (Entity (N)) then + if Raise_Expression_Present then + declare + Map : constant Elist_Id := New_Elmt_List; + begin + Append_Elmt (Object_Entity, Map); + Append_Elmt (Object_Entity_M, Map); + Expr_M := New_Copy_Tree (Expr, Map => Map); + end; + end if; - -- If type has predicates, process them + -- Build the main predicate function - if Has_Predicates (Entity (N)) then - return Stat_Pred (Entity (N)); + declare + SId : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + -- The entity for the the function spec - -- For static subtype without predicates, get range + SIdB : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + -- The entity for the function body - elsif Is_Static_Subtype (Entity (N)) then - SLo := Expr_Value (Type_Low_Bound (Entity (N))); - SHi := Expr_Value (Type_High_Bound (Entity (N))); - return RList'(1 => REnt'(SLo, SHi)); + Spec : Node_Id; + FDecl : Node_Id; + FBody : Node_Id; - -- Any other type makes us non-static + begin + -- Build function declaration - else - raise Non_Static; - end if; + Set_Ekind (SId, E_Function); + Set_Is_Internal (SId); + Set_Is_Predicate_Function (SId); + Set_Predicate_Function (Typ, SId); - -- Any other kind of identifier in predicate (e.g. a non-static - -- expression value) means this is not a static predicate. + -- The predicate function is shared between views of a type - else - raise Non_Static; + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Set_Predicate_Function (Full_View (Typ), SId); end if; - end if; - end Membership_Entry; - --------------- - -- Stat_Pred -- - --------------- + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); - function Stat_Pred (Typ : Entity_Id) return RList is - begin - -- Not static if type does not have static predicates + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); - if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then - raise Non_Static; - end if; + -- Build function body - -- Otherwise we convert the predicate list to a range list + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SIdB, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); - declare - Result : RList (1 .. List_Length (Static_Predicate (Typ))); - P : Node_Id; + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Expr)))); - begin - P := First (Static_Predicate (Typ)); - for J in Result'Range loop - Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); - Next (P); - end loop; + -- Insert declaration before freeze node and body after - return Result; + Insert_Before_And_Analyze (N, FDecl); + Insert_After_And_Analyze (N, FBody); end; - end Stat_Pred; - - -- Start of processing for Build_Static_Predicate - begin - -- Now analyze the expression to see if it is a static predicate + -- Test for raise expressions present and if so build M version - declare - Ranges : constant RList := Get_RList (Expr); - -- Range list from expression if it is static + if Raise_Expression_Present then + declare + SId : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "PredicateM")); + -- The entity for the the function spec - Plist : List_Id; + SIdB : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "PredicateM")); + -- The entity for the function body - begin - -- Convert range list into a form for the static predicate. In the - -- Ranges array, we just have raw ranges, these must be converted - -- to properly typed and analyzed static expressions or range nodes. + Spec : Node_Id; + FDecl : Node_Id; + FBody : Node_Id; + BTemp : Entity_Id; - -- Note: here we limit ranges to the ranges of the subtype, so that - -- a predicate is always false for values outside the subtype. That - -- seems fine, such values are invalid anyway, and considering them - -- to fail the predicate seems allowed and friendly, and furthermore - -- simplifies processing for case statements and loops. + begin + -- Mark any raise expressions for special expansion - Plist := New_List; + Process_REs (Expr_M); - for J in Ranges'Range loop - declare - Lo : Uint := Ranges (J).Lo; - Hi : Uint := Ranges (J).Hi; + -- Build function declaration - begin - -- Ignore completely out of range entry + Set_Ekind (SId, E_Function); + Set_Is_Predicate_Function_M (SId); + Set_Predicate_Function_M (Typ, SId); - if Hi < TLo or else Lo > THi then - null; + -- The predicate function is shared between views of a type - -- Otherwise process entry + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Set_Predicate_Function_M (Full_View (Typ), SId); + end if; - else - -- Adjust out of range value to subtype range + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity_M, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); - if Lo < TLo then - Lo := TLo; - end if; + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); - if Hi > THi then - Hi := THi; - end if; + -- Build function body - -- Convert range into required form + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SIdB, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); - Append_To (Plist, Build_Range (Lo, Hi)); - end if; - end; - end loop; + -- Build the body, we declare the boolean expression before + -- doing the return, because we are not really confident of + -- what happens if a return appears within a return. - -- Processing was successful and all entries were static, so now we - -- can store the result as the predicate list. + BTemp := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('B')); - Set_Static_Predicate (Typ, Plist); + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, - -- The processing for static predicates put the expression into - -- canonical form as a series of ranges. It also eliminated - -- duplicates and collapsed and combined ranges. We might as well - -- replace the alternatives list of the right operand of the - -- membership test with the static predicate list, which will - -- usually be more efficient. + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => BTemp, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => Expr_M)), - declare - New_Alts : constant List_Id := New_List; - Old_Node : Node_Id; - New_Node : Node_Id; + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (BTemp, Loc))))); - begin - Old_Node := First (Plist); - while Present (Old_Node) loop - New_Node := New_Copy (Old_Node); + -- Insert declaration before freeze node and body after - if Nkind (New_Node) = N_Range then - Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); - Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); - end if; + Insert_Before_And_Analyze (N, FDecl); + Insert_After_And_Analyze (N, FBody); + end; + end if; - Append_To (New_Alts, New_Node); - Next (Old_Node); - end loop; + if Is_Discrete_Type (Typ) then - -- If empty list, replace by False + -- Attempt to build a static predicate for a discrete subtype. + -- This action may fail because the actual expression may not be + -- static. Note that the presence of an inherited or explicitly + -- declared dynamic predicate is orthogonal to this check because + -- we are only interested in the static predicate. - if Is_Empty_List (New_Alts) then - Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); + Build_Discrete_Static_Predicate (Typ, Expr, Object_Name); - -- Else replace by set membership test + -- Emit an error when the predicate is categorized as static + -- but its expression is dynamic. - else - Rewrite (Expr, - Make_In (Loc, - Left_Opnd => Make_Identifier (Loc, Nam), - Right_Opnd => Empty, - Alternatives => New_Alts)); + if Present (Static_Predic) + and then No (Static_Predicate (Typ)) + then + Error_Msg_F + ("expression does not have required form for " + & "static predicate", + Next (First (Pragma_Argument_Associations + (Static_Predic)))); + end if; - -- Resolve new expression in function context + -- If a static predicate applies on other types, that's an error: + -- either the type is scalar but non-static, or it's not even a + -- scalar type. We do not issue an error on generated types, as + -- these may be duplicates of the same error on a source type. - Install_Formals (Predicate_Function (Typ)); - Push_Scope (Predicate_Function (Typ)); - Analyze_And_Resolve (Expr, Standard_Boolean); - Pop_Scope; - end if; - end; - end; + elsif Present (Static_Predic) and then Comes_From_Source (Typ) then + if Is_Real_Type (Typ) then + Error_Msg_FE + ("static predicates not implemented for real type&", + Typ, Typ); - -- If non-static, return doing nothing + elsif Is_Scalar_Type (Typ) then + Error_Msg_FE + ("static predicate not allowed for non-static type&", + Typ, Typ); - exception - when Non_Static => - return; - end Build_Static_Predicate; + else + Error_Msg_FE + ("static predicate not allowed for non-scalar type&", + Typ, Typ); + end if; + end if; + end if; + end Build_Predicate_Functions; ----------------------------------------- -- Check_Aspect_At_End_Of_Declarations -- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f05d084ce24e..727a994a5436 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1581,6 +1581,7 @@ package body Sem_Util is if Compile_Time_Known_Value (Expr) and then Has_Predicates (Typ) + and then Is_Discrete_Type (Typ) and then Present (Static_Predicate (Typ)) and then not Has_Dynamic_Predicate_Aspect (Typ) then diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb index 83bdff6cd5d5..f2f036bfc5f0 100644 --- a/gcc/ada/urealp.adb +++ b/gcc/ada/urealp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -1354,13 +1354,13 @@ package body Urealp is and then Val.Den >= -16 then if Val.Den = 1 then - T := Val.Num * (10/2); + T := Val.Num * (10 / 2); UI_Write (T / 10, Decimal); Write_Char ('.'); UI_Write (T mod 10, Decimal); elsif Val.Den = 2 then - T := Val.Num * (100/4); + T := Val.Num * (100 / 4); UI_Write (T / 100, Decimal); Write_Char ('.'); UI_Write (T mod 100 / 10, Decimal); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index e5e5059302c9..d8118ba34af6 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -5677,30 +5677,30 @@ package VMS_Data is -- -- All combinations of line metrics options are allowed. - S_Metric_Complexity : aliased constant S := "/COMPLEXITY_METRICS=" & - "ALL " & - "--complexity-all " & - "NONE " & - "--no-complexity-all " & - "CYCLOMATIC " & - "--complexity-cyclomatic " & - "NOCYCLOMATIC " & - "--no-complexity-cyclomatic "& - "ESSENTIAL " & - "--complexity-essential " & - "NOESSENTIAL " & - "--no-complexity-essential " & - "LOOP_NESTING " & - "--loop-nesting " & - "NOLOOP_NESTING " & - "--no-loop-nesting " & - "AVERAGE_COMPLEXITY " & - "--complexity-average " & - "NOAVERAGE_COMPLEXITY " & - "--no-complexity-average " & - "EXTRA_EXIT_POINTS " & - "--extra-exit-points " & - "NOEXTRA_EXIT_POINTS " & + S_Metric_Complexity : aliased constant S := "/COMPLEXITY_METRICS=" & + "ALL " & + "--complexity-all " & + "NONE " & + "--no-complexity-all " & + "CYCLOMATIC " & + "--complexity-cyclomatic " & + "NOCYCLOMATIC " & + "--no-complexity-cyclomatic " & + "ESSENTIAL " & + "--complexity-essential " & + "NOESSENTIAL " & + "--no-complexity-essential " & + "LOOP_NESTING " & + "--loop-nesting " & + "NOLOOP_NESTING " & + "--no-loop-nesting " & + "AVERAGE_COMPLEXITY " & + "--complexity-average " & + "NOAVERAGE_COMPLEXITY " & + "--no-complexity-average " & + "EXTRA_EXIT_POINTS " & + "--extra-exit-points " & + "NOEXTRA_EXIT_POINTS " & "--no-extra-exit-points"; -- /COMPLEXITY_METRICS=(option, option ...)