aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2014-07-18 11:20:28 +0200
committerArnaud Charlet <charlet@gcc.gnu.org>2014-07-18 11:20:28 +0200
commitbaa571ab785c7b183d1dda08a077d1658e28c4f1 (patch)
tree2340b57ac0d4c3b76bc55e007451fe73864a209b
parentfc999c5d2e9f0f594fe82739494fb36b0b428384 (diff)
downloadgcc-baa571ab785c7b183d1dda08a077d1658e28c4f1.zip
gcc-baa571ab785c7b183d1dda08a077d1658e28c4f1.tar.gz
gcc-baa571ab785c7b183d1dda08a077d1658e28c4f1.tar.bz2
[multiple changes]
2014-07-18 Robert Dewar <dewar@adacore.com> * 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 <schonberg@adacore.com> * 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 <derodat@adacore.com> * 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 <celier@adacore.com> * 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 <quinot@adacore.com> * g-sercom.ads (Set): document possible data loss. 2014-07-18 Ed Schonberg <schonberg@adacore.com> * 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. From-SVN: r212782
Diffstat
-rw-r--r--gcc/ada/ChangeLog42
-rw-r--r--gcc/ada/a-strunb-shared.adb4
-rw-r--r--gcc/ada/atree.ads4
-rw-r--r--gcc/ada/einfo.adb10
-rw-r--r--gcc/ada/exp_attr.adb52
-rw-r--r--gcc/ada/g-sercom.ads9
-rw-r--r--gcc/ada/get_scos.adb11
-rw-r--r--gcc/ada/gnat_ugn.texi7
-rw-r--r--gcc/ada/lib.ads6
-rw-r--r--gcc/ada/par_sco.adb9
-rw-r--r--gcc/ada/s-auxdec-vms_64.ads64
-rw-r--r--gcc/ada/s-auxdec.ads64
-rw-r--r--gcc/ada/s-rannum.adb4
-rw-r--r--gcc/ada/scos.ads8
-rw-r--r--gcc/ada/scos.h88
-rw-r--r--gcc/ada/sem_ch13.adb1789
-rw-r--r--gcc/ada/sem_util.adb1
-rw-r--r--gcc/ada/urealp.adb6
-rw-r--r--gcc/ada/vms_data.ads48
19 files changed, 1207 insertions, 1019 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 51c2bf8..5585fab 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,47 @@
2014-07-18 Robert Dewar <dewar@adacore.com>
+ * 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 <schonberg@adacore.com>
+
+ * 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 <derodat@adacore.com>
+
+ * 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 <celier@adacore.com>
+
+ * 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 <quinot@adacore.com>
+
+ * g-sercom.ads (Set): document possible data loss.
+
+2014-07-18 Ed Schonberg <schonberg@adacore.com>
+
+ * 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 <dewar@adacore.com>
+
* par_sco.adb, a-reatim.ads, exp_attr.adb, sem_util.adb: Minor
reformatting.
diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb
index dac8d23..caeb3a0 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 e51cf88..38491d2 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 9fc6760..79da6f9 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 544a923..9e427b5 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 573eba2..18ee984 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 ca90a85..4f82139 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 629fac8..83b0679 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 fea2f14..0de88fe 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 6fe803d..0f923ca 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 8707f46..1bac3fb 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 a34d608..59ba5ec 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 bfcea55..af620d7 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 6efc5ce..0758f48 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 0000000..d997c9d
--- /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 be28f94..a9cdc2c 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)
- then
- Build_Static_Predicate (Typ, Expr, Object_Name);
+ Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
- -- Emit an error when the predicate is categorized as static
- -- but its expression is dynamic.
+ -- 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;
+ 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;
-- 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 f05d084..727a994 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 83bdff6..f2f036b 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 e5e5059..d8118ba 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 ...)
generated by cgit v1.1 at 2024-10-09 06:37:23 +0000