Skip to content

R
riscv-gcc-1
Commit 2010d078 by Arnaud Charlet
Options

[multiple changes] 

2011-08-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Fully_Conformant_Expressions): handle quantified
	expressions.

2011-08-01  Arnaud Charlet  <charlet@adacore.com>

	* sem_ch8.adb: Minor code editing.
	* s-vxwext.adb: Remove trailing space.
	* freeze.adb, freeze.ads, errout.ads, erroutc.adb: Fix GPLv3 header for
	consistency with other files.

2011-08-01  Thomas Quinot  <quinot@adacore.com>

	* s-auxdec.ads, s-auxdec-vms_64.ads: Minor reformatting.

2011-08-01  Ed Schonberg  <schonberg@adacore.com>

	* par-ch10.adb: reject parameterized expressions as compilation unit.
	* sem_ch4.adb: handle properly conditional expression with overloaded
	then_clause and no else_clause.

2011-08-01  Tristan Gingold  <gingold@adacore.com>

	* s-parame-vms-alpha.ads, s-parame-vms-ia64.ads: Redeclare C_Address
	like done by System.Aux_DEC.
	* env.c (__gnat_setenv) [VMS]: Put logicals into LNM$PROCESS table.

From-SVN: r177050
parent f2c308fa
Showing with 151 additions and 78 deletions
gcc/ada/ChangeLog
2011-08-01 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Fully_Conformant_Expressions): handle quantified
expressions.
2011-08-01 Arnaud Charlet <charlet@adacore.com>
* sem_ch8.adb: Minor code editing.
* s-vxwext.adb: Remove trailing space.
* freeze.adb, freeze.ads, errout.ads, erroutc.adb: Fix GPLv3 header for
consistency with other files.
2011-08-01 Thomas Quinot <quinot@adacore.com>
* s-auxdec.ads, s-auxdec-vms_64.ads: Minor reformatting.
2011-08-01 Ed Schonberg <schonberg@adacore.com>
* par-ch10.adb: reject parameterized expressions as compilation unit.
* sem_ch4.adb: handle properly conditional expression with overloaded
then_clause and no else_clause.
2011-08-01 Tristan Gingold <gingold@adacore.com>
* s-parame-vms-alpha.ads, s-parame-vms-ia64.ads: Redeclare C_Address
like done by System.Aux_DEC.
* env.c (__gnat_setenv) [VMS]: Put logicals into LNM$PROCESS table.
2011-08-01 Yannick Moy <moy@adacore.com> 2011-08-01 Yannick Moy <moy@adacore.com>
* par-endh.adb (Check_End): issue a syntax error in SPARK mode for * par-endh.adb (Check_End): issue a syntax error in SPARK mode for
......
gcc/ada/env.c
...@@ -111,8 +111,7 @@ __gnat_setenv (char *name, char *value) ...@@ -111,8 +111,7 @@ __gnat_setenv (char *name, char *value)
{ {
#if defined (VMS) #if defined (VMS)
struct dsc$descriptor_s name_desc; struct dsc$descriptor_s name_desc;
/* Put in JOB table for now, so that the project stuff at least works. */ $DESCRIPTOR (table_desc, "LNM$PROCESS");
$DESCRIPTOR (table_desc, "LNM$JOB");
char *host_pathspec = value; char *host_pathspec = value;
char *copy_pathspec; char *copy_pathspec;
int num_dirs_in_pathspec = 1; int num_dirs_in_pathspec = 1;
......
gcc/ada/errout.ads
...@@ -13,11 +13,10 @@ ...@@ -13,11 +13,10 @@
-- ware Foundation; either version 3, or (at your option) any later ver- -- -- 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- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. -- -- 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 --
-- You should have received a copy of the GNU General Public License along -- -- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- with this program; see file COPYING3. If not see -- -- http://www.gnu.org/licenses for a complete copy of the license. --
-- <http://www.gnu.org/licenses/>. --
-- -- -- --
-- GNAT was originally developed by the GNAT team at New York University. -- -- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- Extensive contributions were provided by Ada Core Technologies Inc. --
......
gcc/ada/erroutc.adb
...@@ -13,11 +13,10 @@ ...@@ -13,11 +13,10 @@
-- ware Foundation; either version 3, or (at your option) any later ver- -- -- 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- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. -- -- 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 --
-- You should have received a copy of the GNU General Public License along -- -- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- with this program; see file COPYING3. If not see -- -- http://www.gnu.org/licenses for a complete copy of the license. --
-- <http://www.gnu.org/licenses/>. --
-- -- -- --
-- GNAT was originally developed by the GNAT team at New York University. -- -- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- Extensive contributions were provided by Ada Core Technologies Inc. --
......
gcc/ada/freeze.adb
...@@ -13,11 +13,10 @@ ...@@ -13,11 +13,10 @@
-- ware Foundation; either version 3, or (at your option) any later ver- -- -- 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- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. -- -- 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 --
-- You should have received a copy of the GNU General Public License along -- -- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- with this program; see file COPYING3. If not see -- -- http://www.gnu.org/licenses for a complete copy of the license. --
-- <http://www.gnu.org/licenses/>. --
-- -- -- --
-- GNAT was originally developed by the GNAT team at New York University. -- -- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- Extensive contributions were provided by Ada Core Technologies Inc. --
......
gcc/ada/freeze.ads
...@@ -13,11 +13,10 @@ ...@@ -13,11 +13,10 @@
-- ware Foundation; either version 3, or (at your option) any later ver- -- -- 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- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. -- -- 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 --
-- You should have received a copy of the GNU General Public License along -- -- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- with this program; see file COPYING3. If not see -- -- http://www.gnu.org/licenses for a complete copy of the license. --
-- <http://www.gnu.org/licenses/>. --
-- -- -- --
-- GNAT was originally developed by the GNAT team at New York University. -- -- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- Extensive contributions were provided by Ada Core Technologies Inc. --
......
gcc/ada/par-ch10.adb
...@@ -563,6 +563,11 @@ package body Ch10 is ...@@ -563,6 +563,11 @@ package body Ch10 is
then then
Name_Node := Defining_Unit_Name (Unit_Node); Name_Node := Defining_Unit_Name (Unit_Node);
elsif Nkind (Unit_Node) = N_Parameterized_Expression then
Error_Msg_SP
("parameterized expression cannot be used as compilation unit");
return Comp_Unit_Node;
-- Anything else is a serious error, abandon scan -- Anything else is a serious error, abandon scan
else else
......
gcc/ada/s-auxdec-vms_64.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -285,9 +285,9 @@ package System.Aux_DEC is ...@@ -285,9 +285,9 @@ package System.Aux_DEC is
pragma Import (Intrinsic, Import_Address); pragma Import (Intrinsic, Import_Address);
pragma Import (Intrinsic, Import_Largest_Value); pragma Import (Intrinsic, Import_Largest_Value);
-- For the following declarations, note that the declaration without -- For the following declarations, note that the declaration without a
-- a Retry_Count parameter means to retry infinitely. A value of zero -- Retry_Count parameter means to retry infinitely. A value of zero for
-- for the Retry_Count parameter means do not retry. -- the Retry_Count parameter means do not retry.
-- Interlocked-instruction procedures -- Interlocked-instruction procedures
...@@ -303,8 +303,7 @@ package System.Aux_DEC is ...@@ -303,8 +303,7 @@ package System.Aux_DEC is
Value : Short_Integer; Value : Short_Integer;
end record; end record;
for Aligned_Word'Alignment use for Aligned_Word'Alignment use Integer'Min (2, Standard'Maximum_Alignment);
Integer'Min (2, Standard'Maximum_Alignment);
procedure Clear_Interlocked procedure Clear_Interlocked
(Bit : in out Boolean; (Bit : in out Boolean;
...@@ -337,9 +336,9 @@ package System.Aux_DEC is ...@@ -337,9 +336,9 @@ package System.Aux_DEC is
for Aligned_Long_Integer'Alignment use for Aligned_Long_Integer'Alignment use
Integer'Min (8, Standard'Maximum_Alignment); Integer'Min (8, Standard'Maximum_Alignment);
-- For the following declarations, note that the declaration without -- For the following declarations, note that the declaration without a
-- a Retry_Count parameter mean to retry infinitely. A value of zero -- Retry_Count parameter mean to retry infinitely. A value of zero for
-- for the Retry_Count means do not retry. -- the Retry_Count means do not retry.
procedure Add_Atomic procedure Add_Atomic
(To : in out Aligned_Integer; (To : in out Aligned_Integer;
...@@ -407,12 +406,11 @@ package System.Aux_DEC is ...@@ -407,12 +406,11 @@ package System.Aux_DEC is
Old_Value : out Long_Integer; Old_Value : out Long_Integer;
Success_Flag : out Boolean); Success_Flag : out Boolean);
type Insq_Status is type Insq_Status is (Fail_No_Lock, OK_Not_First, OK_First);
(Fail_No_Lock, OK_Not_First, OK_First);
for Insq_Status use for Insq_Status use
(Fail_No_Lock => -1, (Fail_No_Lock => -1,
OK_Not_First => 0, OK_Not_First => 0,
OK_First => +1); OK_First => +1);
type Remq_Status is ( type Remq_Status is (
...@@ -423,7 +421,7 @@ package System.Aux_DEC is ...@@ -423,7 +421,7 @@ package System.Aux_DEC is
for Remq_Status use for Remq_Status use
(Fail_No_Lock => -1, (Fail_No_Lock => -1,
Fail_Was_Empty => 0, Fail_Was_Empty => 0,
OK_Not_Empty => +1, OK_Not_Empty => +1,
OK_Empty => +2); OK_Empty => +2);
...@@ -453,7 +451,7 @@ private ...@@ -453,7 +451,7 @@ private
No_Addr : constant Address := Null_Address; No_Addr : constant Address := Null_Address;
-- An AST_Handler value is from a typing point of view simply a pointer -- An AST_Handler value is from a typing point of view simply a pointer
-- to a procedure taking a single 64bit parameter. However, this -- to a procedure taking a single 64 bit parameter. However, this
-- is a bit misleading, because the data that this pointer references is -- is a bit misleading, because the data that this pointer references is
-- highly stylized. See body of System.AST_Handling for full details. -- highly stylized. See body of System.AST_Handling for full details.
......
gcc/ada/s-auxdec.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -41,14 +41,13 @@ package System.Aux_DEC is ...@@ -41,14 +41,13 @@ package System.Aux_DEC is
pragma Preelaborate; pragma Preelaborate;
subtype Short_Address is Address; subtype Short_Address is Address;
-- In some versions of System.Aux_DEC, notably that for VMS on the -- In some versions of System.Aux_DEC, notably that for VMS on IA64, there
-- ia64, there are two address types (64-bit and 32-bit), and the -- are two address types (64-bit and 32-bit), and the name Short_Address
-- name Short_Address is used for the short address form. To avoid -- is used for the short address form. To avoid difficulties (in regression
-- difficulties (in regression tests and elsewhere) with units that -- tests and elsewhere) with units that reference Short_Address, it is
-- reference Short_Address, it is provided for other targets as a -- provided for other targets as a synonym for the normal Address type,
-- synonym for the normal Address type, and, as in the case where -- and, as in the case where the lengths are different, Address and
-- the lengths are different, Address and Short_Address can be -- Short_Address can be freely inter-converted.
-- freely inter-converted.
type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1; type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1;
for Integer_8'Size use 8; for Integer_8'Size use 8;
...@@ -272,9 +271,9 @@ package System.Aux_DEC is ...@@ -272,9 +271,9 @@ package System.Aux_DEC is
pragma Import (Intrinsic, Import_Address); pragma Import (Intrinsic, Import_Address);
pragma Import (Intrinsic, Import_Largest_Value); pragma Import (Intrinsic, Import_Largest_Value);
-- For the following declarations, note that the declaration without -- For the following declarations, note that the declaration without a
-- a Retry_Count parameter means to retry infinitely. A value of zero -- Retry_Count parameter means to retry infinitely. A value of zero for
-- for the Retry_Count parameter means do not retry. -- the Retry_Count parameter means do not retry.
-- Interlocked-instruction procedures -- Interlocked-instruction procedures
...@@ -290,8 +289,7 @@ package System.Aux_DEC is ...@@ -290,8 +289,7 @@ package System.Aux_DEC is
Value : Short_Integer; Value : Short_Integer;
end record; end record;
for Aligned_Word'Alignment use for Aligned_Word'Alignment use Integer'Min (2, Standard'Maximum_Alignment);
Integer'Min (2, Standard'Maximum_Alignment);
procedure Clear_Interlocked procedure Clear_Interlocked
(Bit : in out Boolean; (Bit : in out Boolean;
...@@ -324,9 +322,9 @@ package System.Aux_DEC is ...@@ -324,9 +322,9 @@ package System.Aux_DEC is
for Aligned_Long_Integer'Alignment use for Aligned_Long_Integer'Alignment use
Integer'Min (8, Standard'Maximum_Alignment); Integer'Min (8, Standard'Maximum_Alignment);
-- For the following declarations, note that the declaration without -- For the following declarations, note that the declaration without a
-- a Retry_Count parameter mean to retry infinitely. A value of zero -- Retry_Count parameter mean to retry infinitely. A value of zero for
-- for the Retry_Count means do not retry. -- the Retry_Count means do not retry.
procedure Add_Atomic procedure Add_Atomic
(To : in out Aligned_Integer; (To : in out Aligned_Integer;
...@@ -394,12 +392,11 @@ package System.Aux_DEC is ...@@ -394,12 +392,11 @@ package System.Aux_DEC is
Old_Value : out Long_Integer; Old_Value : out Long_Integer;
Success_Flag : out Boolean); Success_Flag : out Boolean);
type Insq_Status is type Insq_Status is (Fail_No_Lock, OK_Not_First, OK_First);
(Fail_No_Lock, OK_Not_First, OK_First);
for Insq_Status use for Insq_Status use
(Fail_No_Lock => -1, (Fail_No_Lock => -1,
OK_Not_First => 0, OK_Not_First => 0,
OK_First => +1); OK_First => +1);
type Remq_Status is ( type Remq_Status is (
...@@ -410,7 +407,7 @@ package System.Aux_DEC is ...@@ -410,7 +407,7 @@ package System.Aux_DEC is
for Remq_Status use for Remq_Status use
(Fail_No_Lock => -1, (Fail_No_Lock => -1,
Fail_Was_Empty => 0, Fail_Was_Empty => 0,
OK_Not_Empty => +1, OK_Not_Empty => +1,
OK_Empty => +2); OK_Empty => +2);
...@@ -440,7 +437,7 @@ private ...@@ -440,7 +437,7 @@ private
No_Addr : constant Address := Null_Address; No_Addr : constant Address := Null_Address;
-- An AST_Handler value is from a typing point of view simply a pointer -- An AST_Handler value is from a typing point of view simply a pointer
-- to a procedure taking a single 64bit parameter. However, this -- to a procedure taking a single 64 bit parameter. However, this
-- is a bit misleading, because the data that this pointer references is -- is a bit misleading, because the data that this pointer references is
-- highly stylized. See body of System.AST_Handling for full details. -- highly stylized. See body of System.AST_Handling for full details.
......
gcc/ada/s-parame-vms-alpha.ads
...@@ -46,8 +46,6 @@ ...@@ -46,8 +46,6 @@
-- Note: do not introduce any pragma Inline statements into this unit, since -- Note: do not introduce any pragma Inline statements into this unit, since
-- otherwise the relinking and rebinding capability would be deactivated. -- otherwise the relinking and rebinding capability would be deactivated.
with System.Aux_DEC;
package System.Parameters is package System.Parameters is
pragma Pure; pragma Pure;
...@@ -113,10 +111,13 @@ package System.Parameters is ...@@ -113,10 +111,13 @@ package System.Parameters is
-- of all targets. For example, in OpenVMS long /= Long_Integer. -- of all targets. For example, in OpenVMS long /= Long_Integer.
ptr_bits : constant := 32; ptr_bits : constant := 32;
subtype C_Address is System.Short_Address; subtype C_Address is System.Address
-- Number of bits in Interaces.C pointers, normally a standard address, range -2 ** (ptr_bits - 1) .. 2 ** (ptr_bits - 1) - 1;
for C_Address'Object_Size use ptr_bits;
-- Number of bits in Interfaces.C pointers, normally a standard address,
-- except on 64-bit VMS where they are 32-bit addresses, for compatibility -- except on 64-bit VMS where they are 32-bit addresses, for compatibility
-- with legacy code. -- with legacy code. System.Aux_DEC.Short_Address can't be used because of
-- elaboration circularity.
C_Malloc_Linkname : constant String := "__gnat_malloc32"; C_Malloc_Linkname : constant String := "__gnat_malloc32";
-- Name of runtime function used to allocate such a pointer -- Name of runtime function used to allocate such a pointer
......
gcc/ada/s-parame-vms-ia64.ads
...@@ -46,8 +46,6 @@ ...@@ -46,8 +46,6 @@
-- Note: do not introduce any pragma Inline statements into this unit, since -- Note: do not introduce any pragma Inline statements into this unit, since
-- otherwise the relinking and rebinding capability would be deactivated. -- otherwise the relinking and rebinding capability would be deactivated.
with System.Aux_DEC;
package System.Parameters is package System.Parameters is
pragma Pure; pragma Pure;
...@@ -113,10 +111,14 @@ package System.Parameters is ...@@ -113,10 +111,14 @@ package System.Parameters is
-- of all targets. For example, in OpenVMS long /= Long_Integer. -- of all targets. For example, in OpenVMS long /= Long_Integer.
ptr_bits : constant := 32; ptr_bits : constant := 32;
subtype C_Address is System.Short_Address; subtype C_Address is System.Address
range -2 ** (ptr_bits - 1) .. 2 ** (ptr_bits - 1) - 1;
for C_Address'Object_Size use ptr_bits;
-- Number of bits in Interaces.C pointers, normally a standard address, -- Number of bits in Interaces.C pointers, normally a standard address,
-- except on 64-bit VMS where they are 32-bit addresses, for compatibility -- except on 64-bit VMS where they are 32-bit addresses, for compatibility
-- with legacy code. -- with legacy code.
-- System.Aux_DEC.Short_Address can't be used because of elaboration
-- circularity.
C_Malloc_Linkname : constant String := "__gnat_malloc32"; C_Malloc_Linkname : constant String := "__gnat_malloc32";
-- Name of runtime function used to allocate such a pointer -- Name of runtime function used to allocate such a pointer
......
gcc/ada/s-vxwext.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2009-2010, Free Software Foundation, Inc. -- -- Copyright (C) 2009-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
......
gcc/ada/sem_ch4.adb
...@@ -1495,19 +1495,23 @@ package body Sem_Ch4 is ...@@ -1495,19 +1495,23 @@ package body Sem_Ch4 is
begin begin
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
Get_First_Interp (Then_Expr, I, It); Get_First_Interp (Then_Expr, I, It);
while Present (It.Nam) loop if No (Else_Expr) then
-- if no else_expression the conditional must be boolean.
-- For each possible interpretation of the Then Expression, Set_Etype (N, Standard_Boolean);
-- add it only if the else expression has a compatible type. else
while Present (It.Nam) loop
-- Is this right if Else_Expr is empty? -- For each possible intepretation of the Then Expression,
-- add it only if the else expression has a compatible type.
if Has_Compatible_Type (Else_Expr, It.Typ) then if Has_Compatible_Type (Else_Expr, It.Typ) then
Add_One_Interp (N, It.Typ, It.Typ); Add_One_Interp (N, It.Typ, It.Typ);
end if; end if;
Get_Next_Interp (I, It); Get_Next_Interp (I, It);
end loop; end loop;
end if;
end; end;
end if; end if;
end Analyze_Conditional_Expression; end Analyze_Conditional_Expression;
......
gcc/ada/sem_ch6.adb
...@@ -6685,6 +6685,50 @@ package body Sem_Ch6 is ...@@ -6685,6 +6685,50 @@ package body Sem_Ch6 is
and then and then
FCE (Expression (E1), Expression (E2)); FCE (Expression (E1), Expression (E2));
when N_Quantified_Expression =>
if not FCE (Condition (E1), Condition (E2)) then
return False;
end if;
if Present (Loop_Parameter_Specification (E1))
and then Present (Loop_Parameter_Specification (E2))
then
declare
L1 : constant Node_Id :=
Loop_Parameter_Specification (E1);
L2 : constant Node_Id :=
Loop_Parameter_Specification (E2);
begin
return
Reverse_Present (L1) = Reverse_Present (L2)
and then
FCE (Defining_Identifier (L1),
Defining_Identifier (L2))
and then
FCE (Discrete_Subtype_Definition (L1),
Discrete_Subtype_Definition (L2));
end;
else -- quantified expression with an iterator
declare
I1 : constant Node_Id := Iterator_Specification (E1);
I2 : constant Node_Id := Iterator_Specification (E2);
begin
return
FCE (Defining_Identifier (I1),
Defining_Identifier (I2))
and then
Of_Present (I1) = Of_Present (I2)
and then
Reverse_Present (I1) = Reverse_Present (I2)
and then FCE (Name (I1), Name (I2))
and then FCE (Subtype_Indication (I1),
Subtype_Indication (I2));
end;
end if;
when N_Range => when N_Range =>
return return
FCE (Low_Bound (E1), Low_Bound (E2)) FCE (Low_Bound (E1), Low_Bound (E2))
......
gcc/ada/sem_ch8.adb
...@@ -6299,8 +6299,7 @@ package body Sem_Ch8 is ...@@ -6299,8 +6299,7 @@ package body Sem_Ch8 is
pragma Assert (not Scope_Stack.Table (J).Is_Active_Stack_Base); pragma Assert (not Scope_Stack.Table (J).Is_Active_Stack_Base);
end loop; end loop;
pragma Assert (False); -- unreachable raise Program_Error; -- unreachable
raise Program_Error;
end Has_Loop_In_Inner_Open_Scopes; end Has_Loop_In_Inner_Open_Scopes;
-------------------- --------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment