diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 51c2bf8eea3..5585fab0ea0 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 dac8d235db1..caeb3a02676 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 e51cf88ba32..38491d2b8ea 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 9fc6760ba25..79da6f9e0f4 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 544a9232f35..9e427b56118 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 573eba280b6..18ee984bb4e 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 ca90a85b4f7..4f821391576 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 629fac81633..83b06792c87 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 fea2f14a1d7..0de88fec708 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 6fe803d9e80..0f923ca2c39 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 8707f46f4c6..1bac3fbac95 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 a34d6089327..59ba5ec8711 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 bfcea556944..af620d70420 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 6efc5cebcc9..0758f48cd02 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 00000000000..d997c9df83a --- /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 be28f94a1d8..a9cdc2cb533 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,6 +6154,859 @@ package body Sem_Ch13 is end if; end Analyze_Record_Representation_Clause; + ------------------------------------- + -- Build_Discrete_Static_Predicate -- + ------------------------------------- + + procedure Build_Discrete_Static_Predicate + (Typ : Entity_Id; + Expr : Node_Id; + Nam : Name_Id) + is + Loc : constant Source_Ptr := Sloc (Expr); + + Non_Static : exception; + -- Raised if something non-static is found + + Btyp : constant Entity_Id := Base_Type (Typ); + + 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 + + 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 + + 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. + + 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. + + 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. + + True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); + -- Range representing True, value must be in the base range + + function "and" (Left : RList; Right : RList) return RList; + -- And's together two range lists, returning a range list. This is a set + -- intersection operation. + + function "or" (Left : RList; Right : RList) return RList; + -- Or's together two range lists, returning a range list. This is a set + -- union operation. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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). + + 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. + + 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. + + 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. + + 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). + + 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. + + ----------- + -- "and" -- + ----------- + + function "and" (Left : RList; Right : RList) return RList is + FEnt : REnt; + -- First range of result + + SLeft : Nat := Left'First; + -- Start of rest of left entries + + SRight : Nat := Right'First; + -- Start of rest of right entries + + begin + -- If either range is True, return the other + + if Is_True (Left) then + return Right; + elsif Is_True (Right) then + return Left; + end if; + + -- If either range is False, return False + + if Is_False (Left) or else Is_False (Right) then + return False_Range; + end if; + + -- Loop to remove entries at start that are disjoint, and thus just + -- get discarded from the result entirely. + + loop + -- If no operands left in either operand, result is false + + if SLeft > Left'Last or else SRight > Right'Last then + return False_Range; + + -- Discard first left operand entry if disjoint with right + + elsif Left (SLeft).Hi < Right (SRight).Lo then + SLeft := SLeft + 1; + + -- Discard first right operand entry if disjoint with left + + elsif Right (SRight).Hi < Left (SLeft).Lo then + SRight := SRight + 1; + + -- Otherwise we have an overlapping entry + + else + exit; + end if; + end loop; + + -- 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. + + FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), + Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); + + -- Now we can remove the entry that ended at a lower value, since its + -- contribution is entirely contained in Fent. + + if Left (SLeft).Hi <= Right (SRight).Hi then + SLeft := SLeft + 1; + else + SRight := SRight + 1; + end if; + + -- 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. + + return + FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); + end "and"; + + ----------- + -- "not" -- + ----------- + + function "not" (Right : RList) return RList is + begin + -- Return True if False range + + if Is_False (Right) then + return True_Range; + end if; + + -- Return False if True range + + if Is_True (Right) then + return False_Range; + end if; + + -- Here if not trivial case + + declare + Result : RList (1 .. Right'Length + 1); + -- May need one more entry for gap at beginning and end + + Count : Nat := 0; + -- Number of entries stored in Result + + begin + -- Gap at start + + if Right (Right'First).Lo > TLo then + Count := Count + 1; + Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); + end if; + + -- Gaps between ranges + + 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; + + -- Gap at end + + if Right (Right'Last).Hi < THi then + Count := Count + 1; + Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); + end if; + + return Result (1 .. Count); + end; + end "not"; + + ---------- + -- "or" -- + ---------- + + function "or" (Left : RList; Right : RList) return RList is + FEnt : REnt; + -- First range of result + + SLeft : Nat := Left'First; + -- Start of rest of left entries + + SRight : Nat := Right'First; + -- Start of rest of right entries + + begin + -- If either range is True, return True + + if Is_True (Left) or else Is_True (Right) then + return True_Range; + end if; + + -- If either range is False (empty), return the other + + if Is_False (Left) then + return Right; + elsif Is_False (Right) then + return Left; + end if; + + -- Initialize result first entry from left or right operand depending + -- on which starts with the lower range. + + if Left (SLeft).Lo < Right (SRight).Lo then + FEnt := Left (SLeft); + SLeft := SLeft + 1; + else + FEnt := Right (SRight); + SRight := SRight + 1; + end if; + + -- This loop eats ranges from left and right operands that are + -- contiguous with the first range we are gathering. + + loop + -- Eat first entry in left operand if contiguous or overlapped by + -- gathered first operand of result. + + 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; + + -- Eat first entry in right operand if contiguous or overlapped by + -- gathered right operand of result. + + 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; + + -- All done if no more entries to eat + + else + exit; + end if; + end loop; + + -- 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 + + return + FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); + end "or"; + + ----------------- + -- Build_Range -- + ----------------- + + function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is + Result : Node_Id; + begin + 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; + + --------------- + -- Build_Val -- + --------------- + + function Build_Val (V : Uint) return Node_Id is + Result : Node_Id; + + 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; + + Set_Etype (Result, Btyp); + Set_Is_Static_Expression (Result); + Set_Analyzed (Result); + return Result; + end Build_Val; + + --------------- + -- Get_RList -- + --------------- + + function Get_RList (Exp : Node_Id) return RList is + Op : Node_Kind; + Val : Uint; + + begin + -- Static expression can only be true or false + + if Is_OK_Static_Expression (Exp) then + if Expr_Value (Exp) = 0 then + return False_Range; + else + return True_Range; + end if; + end if; + + -- Otherwise test node type + + Op := Nkind (Exp); + + case Op is + + -- And + + when N_Op_And | N_And_Then => + return Get_RList (Left_Opnd (Exp)) + and + Get_RList (Right_Opnd (Exp)); + + -- Or + + when N_Op_Or | N_Or_Else => + return Get_RList (Left_Opnd (Exp)) + or + Get_RList (Right_Opnd (Exp)); + + -- Not + + when N_Op_Not => + return not Get_RList (Right_Opnd (Exp)); + + -- Comparisons of type with static value + + when N_Op_Compare => + + -- Type is left operand + + if Is_Type_Ref (Left_Opnd (Exp)) + and then Is_OK_Static_Expression (Right_Opnd (Exp)) + then + Val := Expr_Value (Right_Opnd (Exp)); + + -- Typ is right operand + + elsif Is_Type_Ref (Right_Opnd (Exp)) + and then Is_OK_Static_Expression (Left_Opnd (Exp)) + then + Val := Expr_Value (Left_Opnd (Exp)); + + -- Invert sense of comparison + + 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; + + -- Other cases are non-static + + else + raise Non_Static; + end if; + + -- Construct range according to comparison operation + + case Op is + when N_Op_Eq => + return RList'(1 => REnt'(Val, Val)); + + when N_Op_Ge => + return RList'(1 => REnt'(Val, BHi)); + + when N_Op_Gt => + return RList'(1 => REnt'(Val + 1, BHi)); + + when N_Op_Le => + return RList'(1 => REnt'(BLo, Val)); + + when N_Op_Lt => + return RList'(1 => REnt'(BLo, Val - 1)); + + when N_Op_Ne => + return RList'(REnt'(BLo, Val - 1), REnt'(Val + 1, BHi)); + + when others => + raise Program_Error; + end case; + + -- Membership (IN) + + when N_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; + + if Present (Right_Opnd (Exp)) then + return Membership_Entry (Right_Opnd (Exp)); + else + return Membership_Entries (First (Alternatives (Exp))); + end if; + + -- Negative membership (NOT IN) + + when N_Not_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; + + if Present (Right_Opnd (Exp)) then + return not Membership_Entry (Right_Opnd (Exp)); + else + return not Membership_Entries (First (Alternatives (Exp))); + end if; + + -- Function call, may be call to static predicate + + 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; + + -- Other function call cases are non-static + + raise Non_Static; + + -- Qualified expression, dig out the expression + + when N_Qualified_Expression => + return Get_RList (Expression (Exp)); + + when N_Case_Expression => + declare + Alt : Node_Id; + Choices : List_Id; + Dep : Node_Id; + + 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; + + -- Collect discrete choices in all True alternatives + + Choices := New_List; + Alt := First (Alternatives (Exp)); + while Present (Alt) loop + Dep := Expression (Alt); + + if not Is_Static_Expression (Dep) then + raise Non_Static; + + elsif Is_True (Expr_Value (Dep)) then + Append_List_To (Choices, + New_Copy_List (Discrete_Choices (Alt))); + end if; + + Next (Alt); + end loop; + + return Membership_Entries (First (Choices)); + end; + + -- Expression with actions: if no actions, dig out expression + + when N_Expression_With_Actions => + if Is_Empty_List (Actions (Exp)) then + return Get_RList (Expression (Exp)); + else + raise Non_Static; + end if; + + -- Xor operator + + 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))); + + -- Any other node type is non-static + + when others => + raise Non_Static; + end case; + end Get_RList; + + ------------ + -- Hi_Val -- + ------------ + + 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; + + -------------- + -- Is_False -- + -------------- + + function Is_False (R : RList) return Boolean is + begin + return R'Length = 0; + end Is_False; + + ------------- + -- Is_True -- + ------------- + + 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; + + ----------------- + -- Is_Type_Ref -- + ----------------- + + 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; + + ------------ + -- Lo_Val -- + ------------ + + 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; + + ------------------------ + -- Membership_Entries -- + ------------------------ + + 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; + + ---------------------- + -- Membership_Entry -- + ---------------------- + + function Membership_Entry (N : Node_Id) return RList is + Val : Uint; + SLo : Uint; + SHi : Uint; + + 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; + + -- Static expression case + + elsif Is_Static_Expression (N) then + Val := Expr_Value (N); + return RList'(1 => REnt'(Val, Val)); + + -- Identifier (other than static expression) case + + else pragma Assert (Nkind (N) = N_Identifier); + + -- Type case + + if Is_Type (Entity (N)) then + + -- If type has predicates, process them + + if Has_Predicates (Entity (N)) then + return Stat_Pred (Entity (N)); + + -- For static subtype without predicates, get range + + 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)); + + -- Any other type makes us non-static + + else + raise Non_Static; + end if; + + -- Any other kind of identifier in predicate (e.g. a non-static + -- expression value) means this is not a static predicate. + + else + raise Non_Static; + end if; + end if; + end Membership_Entry; + + --------------- + -- Stat_Pred -- + --------------- + + function Stat_Pred (Typ : Entity_Id) return RList is + begin + -- Not static if type does not have static predicates + + if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then + raise Non_Static; + end if; + + -- Otherwise we convert the predicate list to a range list + + declare + Result : RList (1 .. List_Length (Static_Predicate (Typ))); + P : Node_Id; + + 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; + + return Result; + end; + end Stat_Pred; + + -- Start of processing for Build_Discrete_Static_Predicate + + begin + -- Analyze the expression to see if it is a static predicate + + declare + Ranges : constant RList := Get_RList (Expr); + -- Range list from expression if it is static + + Plist : List_Id; + + 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. + + -- 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. + + Plist := New_List; + + for J in Ranges'Range loop + declare + Lo : Uint := Ranges (J).Lo; + Hi : Uint := Ranges (J).Hi; + + begin + -- Ignore completely out of range entry + + if Hi < TLo or else Lo > THi then + null; + + -- Otherwise process entry + + else + -- Adjust out of range value to subtype range + + if Lo < TLo then + Lo := TLo; + end if; + + if Hi > THi then + Hi := THi; + end if; + + -- Convert range into required form + + Append_To (Plist, Build_Range (Lo, Hi)); + end if; + end; + end loop; + + -- Processing was successful and all entries were static, so now we + -- can store the result as the predicate list. + + Set_Static_Predicate (Typ, Plist); + + -- 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. + + declare + New_Alts : constant List_Id := New_List; + Old_Node : Node_Id; + New_Node : Node_Id; + + begin + Old_Node := First (Plist); + while Present (Old_Node) loop + New_Node := New_Copy (Old_Node); + + 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; + + Append_To (New_Alts, New_Node); + Next (Old_Node); + end loop; + + -- If empty list, replace by False + + if Is_Empty_List (New_Alts) then + Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); + + -- Else replace by set membership test + + else + Rewrite (Expr, + Make_In (Loc, + Left_Opnd => Make_Identifier (Loc, Nam), + Right_Opnd => Empty, + Alternatives => New_Alts)); + + -- Resolve new expression in function context + + Install_Formals (Predicate_Function (Typ)); + Push_Scope (Predicate_Function (Typ)); + Analyze_And_Resolve (Expr, Standard_Boolean); + Pop_Scope; + end if; + end; + end; + + -- If non-static, return doing nothing + + exception + when Non_Static => + return; + end Build_Discrete_Static_Predicate; + ------------------------------------------- -- Build_Invariant_Procedure_Declaration -- ------------------------------------------- @@ -7103,35 +7956,27 @@ package body Sem_Ch13 is end; end if; - if Is_Scalar_Type (Typ) then + if Is_Discrete_Type (Typ) then - -- 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. + -- 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 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) + Build_Discrete_Static_Predicate (Typ, Expr, Object_Name); + + -- Emit an error when the predicate is categorized as static + -- but its expression is dynamic. + + if Present (Static_Predic) + and then No (Static_Predicate (Typ)) then - Build_Static_Predicate (Typ, Expr, Object_Name); - - -- Emit an error when the predicate is categorized as static - -- but its expression is dynamic. - - 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; + Error_Msg_F + ("expression does not have required form for " + & "static predicate", + Next (First (Pragma_Argument_Associations + (Static_Predic)))); end if; -- If a static predicate applies on other types, that's an error: @@ -7140,10 +7985,16 @@ package body Sem_Ch13 is -- these may be duplicates of the same error on a source type. elsif Present (Static_Predic) and then Comes_From_Source (Typ) then - if Is_Scalar_Type (Typ) then + if Is_Real_Type (Typ) then + Error_Msg_FE + ("static predicates not implemented for real type&", + Typ, Typ); + + elsif 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&", @@ -7153,866 +8004,6 @@ package body Sem_Ch13 is end if; end Build_Predicate_Functions; - ---------------------------- - -- Build_Static_Predicate -- - ---------------------------- - - procedure Build_Static_Predicate - (Typ : Entity_Id; - Expr : Node_Id; - Nam : Name_Id) - is - Loc : constant Source_Ptr := Sloc (Expr); - - Non_Static : exception; - -- Raised if something non-static is found - - Btyp : constant Entity_Id := Base_Type (Typ); - - 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 - - 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 - - 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. - - 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. - - 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. - - True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); - -- Range representing True, value must be in the base range - - function "and" (Left : RList; Right : RList) return RList; - -- And's together two range lists, returning a range list. This is a set - -- intersection operation. - - function "or" (Left : RList; Right : RList) return RList; - -- Or's together two range lists, returning a range list. This is a set - -- union operation. - - 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. - - 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. - - 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. - - 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. - - 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. - - 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. - - 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). - - 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. - - 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. - - 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. - - 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). - - 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. - - ----------- - -- "and" -- - ----------- - - function "and" (Left : RList; Right : RList) return RList is - FEnt : REnt; - -- First range of result - - SLeft : Nat := Left'First; - -- Start of rest of left entries - - SRight : Nat := Right'First; - -- Start of rest of right entries - - begin - -- If either range is True, return the other - - if Is_True (Left) then - return Right; - elsif Is_True (Right) then - return Left; - end if; - - -- If either range is False, return False - - if Is_False (Left) or else Is_False (Right) then - return False_Range; - end if; - - -- Loop to remove entries at start that are disjoint, and thus just - -- get discarded from the result entirely. - - loop - -- If no operands left in either operand, result is false - - if SLeft > Left'Last or else SRight > Right'Last then - return False_Range; - - -- Discard first left operand entry if disjoint with right - - elsif Left (SLeft).Hi < Right (SRight).Lo then - SLeft := SLeft + 1; - - -- Discard first right operand entry if disjoint with left - - elsif Right (SRight).Hi < Left (SLeft).Lo then - SRight := SRight + 1; - - -- Otherwise we have an overlapping entry - - else - exit; - end if; - end loop; - - -- 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. - - FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), - Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); - - -- Now we can remove the entry that ended at a lower value, since its - -- contribution is entirely contained in Fent. - - if Left (SLeft).Hi <= Right (SRight).Hi then - SLeft := SLeft + 1; - else - SRight := SRight + 1; - end if; - - -- 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. - - return - FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); - end "and"; - - ----------- - -- "not" -- - ----------- - - function "not" (Right : RList) return RList is - begin - -- Return True if False range - - if Is_False (Right) then - return True_Range; - end if; - - -- Return False if True range - - if Is_True (Right) then - return False_Range; - end if; - - -- Here if not trivial case - - declare - Result : RList (1 .. Right'Length + 1); - -- May need one more entry for gap at beginning and end - - Count : Nat := 0; - -- Number of entries stored in Result - - begin - -- Gap at start - - if Right (Right'First).Lo > TLo then - Count := Count + 1; - Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); - end if; - - -- Gaps between ranges - - 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; - - -- Gap at end - - if Right (Right'Last).Hi < THi then - Count := Count + 1; - Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); - end if; - - return Result (1 .. Count); - end; - end "not"; - - ---------- - -- "or" -- - ---------- - - function "or" (Left : RList; Right : RList) return RList is - FEnt : REnt; - -- First range of result - - SLeft : Nat := Left'First; - -- Start of rest of left entries - - SRight : Nat := Right'First; - -- Start of rest of right entries - - begin - -- If either range is True, return True - - if Is_True (Left) or else Is_True (Right) then - return True_Range; - end if; - - -- If either range is False (empty), return the other - - if Is_False (Left) then - return Right; - elsif Is_False (Right) then - return Left; - end if; - - -- Initialize result first entry from left or right operand depending - -- on which starts with the lower range. - - if Left (SLeft).Lo < Right (SRight).Lo then - FEnt := Left (SLeft); - SLeft := SLeft + 1; - else - FEnt := Right (SRight); - SRight := SRight + 1; - end if; - - -- This loop eats ranges from left and right operands that are - -- contiguous with the first range we are gathering. - - loop - -- Eat first entry in left operand if contiguous or overlapped by - -- gathered first operand of result. - - 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; - - -- Eat first entry in right operand if contiguous or overlapped by - -- gathered right operand of result. - - 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; - - -- All done if no more entries to eat - - else - exit; - end if; - end loop; - - -- 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 - - return - FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); - end "or"; - - ----------------- - -- Build_Range -- - ----------------- - - function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is - Result : Node_Id; - - begin - 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; - - --------------- - -- Build_Val -- - --------------- - - function Build_Val (V : Uint) return Node_Id is - Result : Node_Id; - - 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; - - Set_Etype (Result, Btyp); - Set_Is_Static_Expression (Result); - Set_Analyzed (Result); - return Result; - end Build_Val; - - --------------- - -- Get_RList -- - --------------- - - function Get_RList (Exp : Node_Id) return RList is - Op : Node_Kind; - Val : Uint; - - begin - -- Static expression can only be true or false - - if Is_OK_Static_Expression (Exp) then - - -- For False - - if Expr_Value (Exp) = 0 then - return False_Range; - else - return True_Range; - end if; - end if; - - -- Otherwise test node type - - Op := Nkind (Exp); - - case Op is - - -- And - - when N_Op_And | N_And_Then => - return Get_RList (Left_Opnd (Exp)) - and - Get_RList (Right_Opnd (Exp)); - - -- Or - - when N_Op_Or | N_Or_Else => - return Get_RList (Left_Opnd (Exp)) - or - Get_RList (Right_Opnd (Exp)); - - -- Not - - when N_Op_Not => - return not Get_RList (Right_Opnd (Exp)); - - -- Comparisons of type with static value - - when N_Op_Compare => - - -- Type is left operand - - if Is_Type_Ref (Left_Opnd (Exp)) - and then Is_OK_Static_Expression (Right_Opnd (Exp)) - then - Val := Expr_Value (Right_Opnd (Exp)); - - -- Typ is right operand - - elsif Is_Type_Ref (Right_Opnd (Exp)) - and then Is_OK_Static_Expression (Left_Opnd (Exp)) - then - Val := Expr_Value (Left_Opnd (Exp)); - - -- Invert sense of comparison - - 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; - - -- Other cases are non-static - - else - raise Non_Static; - end if; - - -- Construct range according to comparison operation - - case Op is - when N_Op_Eq => - return RList'(1 => REnt'(Val, Val)); - - when N_Op_Ge => - return RList'(1 => REnt'(Val, BHi)); - - when N_Op_Gt => - return RList'(1 => REnt'(Val + 1, BHi)); - - when N_Op_Le => - return RList'(1 => REnt'(BLo, Val)); - - when N_Op_Lt => - return RList'(1 => REnt'(BLo, Val - 1)); - - when N_Op_Ne => - return RList'(REnt'(BLo, Val - 1), - REnt'(Val + 1, BHi)); - - when others => - raise Program_Error; - end case; - - -- Membership (IN) - - when N_In => - if not Is_Type_Ref (Left_Opnd (Exp)) then - raise Non_Static; - end if; - - if Present (Right_Opnd (Exp)) then - return Membership_Entry (Right_Opnd (Exp)); - else - return Membership_Entries (First (Alternatives (Exp))); - end if; - - -- Negative membership (NOT IN) - - when N_Not_In => - if not Is_Type_Ref (Left_Opnd (Exp)) then - raise Non_Static; - end if; - - if Present (Right_Opnd (Exp)) then - return not Membership_Entry (Right_Opnd (Exp)); - else - return not Membership_Entries (First (Alternatives (Exp))); - end if; - - -- Function call, may be call to static predicate - - 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; - - -- Other function call cases are non-static - - raise Non_Static; - - -- Qualified expression, dig out the expression - - when N_Qualified_Expression => - return Get_RList (Expression (Exp)); - - when N_Case_Expression => - declare - Alt : Node_Id; - Choices : List_Id; - Dep : Node_Id; - - 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; - - -- Collect discrete choices in all True alternatives - - Choices := New_List; - Alt := First (Alternatives (Exp)); - while Present (Alt) loop - Dep := Expression (Alt); - - if not Is_Static_Expression (Dep) then - raise Non_Static; - - elsif Is_True (Expr_Value (Dep)) then - Append_List_To (Choices, - New_Copy_List (Discrete_Choices (Alt))); - end if; - - Next (Alt); - end loop; - - return Membership_Entries (First (Choices)); - end; - - -- Expression with actions: if no actions, dig out expression - - when N_Expression_With_Actions => - if Is_Empty_List (Actions (Exp)) then - return Get_RList (Expression (Exp)); - else - raise Non_Static; - end if; - - -- Xor operator - - 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))); - - -- Any other node type is non-static - - when others => - raise Non_Static; - end case; - end Get_RList; - - ------------ - -- Hi_Val -- - ------------ - - 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; - - -------------- - -- Is_False -- - -------------- - - function Is_False (R : RList) return Boolean is - begin - return R'Length = 0; - end Is_False; - - ------------- - -- Is_True -- - ------------- - - 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; - - ----------------- - -- Is_Type_Ref -- - ----------------- - - 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; - - ------------ - -- Lo_Val -- - ------------ - - 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; - - ------------------------ - -- Membership_Entries -- - ------------------------ - - 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; - - ---------------------- - -- Membership_Entry -- - ---------------------- - - function Membership_Entry (N : Node_Id) return RList is - Val : Uint; - SLo : Uint; - SHi : Uint; - - 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; - - -- Static expression case - - elsif Is_Static_Expression (N) then - Val := Expr_Value (N); - return RList'(1 => REnt'(Val, Val)); - - -- Identifier (other than static expression) case - - else pragma Assert (Nkind (N) = N_Identifier); - - -- Type case - - if Is_Type (Entity (N)) then - - -- If type has predicates, process them - - if Has_Predicates (Entity (N)) then - return Stat_Pred (Entity (N)); - - -- For static subtype without predicates, get range - - 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)); - - -- Any other type makes us non-static - - else - raise Non_Static; - end if; - - -- Any other kind of identifier in predicate (e.g. a non-static - -- expression value) means this is not a static predicate. - - else - raise Non_Static; - end if; - end if; - end Membership_Entry; - - --------------- - -- Stat_Pred -- - --------------- - - function Stat_Pred (Typ : Entity_Id) return RList is - begin - -- Not static if type does not have static predicates - - if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then - raise Non_Static; - end if; - - -- Otherwise we convert the predicate list to a range list - - declare - Result : RList (1 .. List_Length (Static_Predicate (Typ))); - P : Node_Id; - - 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; - - return Result; - end; - end Stat_Pred; - - -- Start of processing for Build_Static_Predicate - - begin - -- Now analyze the expression to see if it is a static predicate - - declare - Ranges : constant RList := Get_RList (Expr); - -- Range list from expression if it is static - - Plist : List_Id; - - 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. - - -- 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. - - Plist := New_List; - - for J in Ranges'Range loop - declare - Lo : Uint := Ranges (J).Lo; - Hi : Uint := Ranges (J).Hi; - - begin - -- Ignore completely out of range entry - - if Hi < TLo or else Lo > THi then - null; - - -- Otherwise process entry - - else - -- Adjust out of range value to subtype range - - if Lo < TLo then - Lo := TLo; - end if; - - if Hi > THi then - Hi := THi; - end if; - - -- Convert range into required form - - Append_To (Plist, Build_Range (Lo, Hi)); - end if; - end; - end loop; - - -- Processing was successful and all entries were static, so now we - -- can store the result as the predicate list. - - Set_Static_Predicate (Typ, Plist); - - -- 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. - - declare - New_Alts : constant List_Id := New_List; - Old_Node : Node_Id; - New_Node : Node_Id; - - begin - Old_Node := First (Plist); - while Present (Old_Node) loop - New_Node := New_Copy (Old_Node); - - 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; - - Append_To (New_Alts, New_Node); - Next (Old_Node); - end loop; - - -- If empty list, replace by False - - if Is_Empty_List (New_Alts) then - Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); - - -- Else replace by set membership test - - else - Rewrite (Expr, - Make_In (Loc, - Left_Opnd => Make_Identifier (Loc, Nam), - Right_Opnd => Empty, - Alternatives => New_Alts)); - - -- Resolve new expression in function context - - Install_Formals (Predicate_Function (Typ)); - Push_Scope (Predicate_Function (Typ)); - Analyze_And_Resolve (Expr, Standard_Boolean); - Pop_Scope; - end if; - end; - end; - - -- If non-static, return doing nothing - - exception - when Non_Static => - return; - end Build_Static_Predicate; - ----------------------------------------- -- Check_Aspect_At_End_Of_Declarations -- ----------------------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f05d084ce24..727a994a543 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 83bdff6cd5d..f2f036bfc5f 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 e5e5059302c..d8118ba34af 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 ...)