+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>
* par-endh.adb (Check_End): issue a syntax error in SPARK mode for
{
#if defined (VMS)
struct dsc$descriptor_s name_desc;
- /* Put in JOB table for now, so that the project stuff at least works. */
- $DESCRIPTOR (table_desc, "LNM$JOB");
+ $DESCRIPTOR (table_desc, "LNM$PROCESS");
char *host_pathspec = value;
char *copy_pathspec;
int num_dirs_in_pathspec = 1;
-- 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. --
--- --
--- You should have received a copy of the GNU General Public License along --
--- with this program; see file COPYING3. If not see --
--- <http://www.gnu.org/licenses/>. --
+-- 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. --
-- 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. --
--- --
--- You should have received a copy of the GNU General Public License along --
--- with this program; see file COPYING3. If not see --
--- <http://www.gnu.org/licenses/>. --
+-- 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. --
-- 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. --
--- --
--- You should have received a copy of the GNU General Public License along --
--- with this program; see file COPYING3. If not see --
--- <http://www.gnu.org/licenses/>. --
+-- 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. --
-- 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. --
--- --
--- You should have received a copy of the GNU General Public License along --
--- with this program; see file COPYING3. If not see --
--- <http://www.gnu.org/licenses/>. --
+-- 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. --
then
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
else
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
pragma Import (Intrinsic, Import_Address);
pragma Import (Intrinsic, Import_Largest_Value);
- -- For the following declarations, note that the declaration without
- -- a Retry_Count parameter means to retry infinitely. A value of zero
- -- for the Retry_Count parameter means do not retry.
+ -- For the following declarations, note that the declaration without a
+ -- Retry_Count parameter means to retry infinitely. A value of zero for
+ -- the Retry_Count parameter means do not retry.
-- Interlocked-instruction procedures
Value : Short_Integer;
end record;
- for Aligned_Word'Alignment use
- Integer'Min (2, Standard'Maximum_Alignment);
+ for Aligned_Word'Alignment use Integer'Min (2, Standard'Maximum_Alignment);
procedure Clear_Interlocked
(Bit : in out Boolean;
for Aligned_Long_Integer'Alignment use
Integer'Min (8, Standard'Maximum_Alignment);
- -- For the following declarations, note that the declaration without
- -- a Retry_Count parameter mean to retry infinitely. A value of zero
- -- for the Retry_Count means do not retry.
+ -- For the following declarations, note that the declaration without a
+ -- Retry_Count parameter mean to retry infinitely. A value of zero for
+ -- the Retry_Count means do not retry.
procedure Add_Atomic
(To : in out Aligned_Integer;
Old_Value : out Long_Integer;
Success_Flag : out Boolean);
- type Insq_Status is
- (Fail_No_Lock, OK_Not_First, OK_First);
+ type Insq_Status is (Fail_No_Lock, OK_Not_First, OK_First);
for Insq_Status use
(Fail_No_Lock => -1,
- OK_Not_First => 0,
+ OK_Not_First => 0,
OK_First => +1);
type Remq_Status is (
for Remq_Status use
(Fail_No_Lock => -1,
- Fail_Was_Empty => 0,
+ Fail_Was_Empty => 0,
OK_Not_Empty => +1,
OK_Empty => +2);
No_Addr : constant Address := Null_Address;
-- 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
-- highly stylized. See body of System.AST_Handling for full details.
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
pragma Preelaborate;
subtype Short_Address is Address;
- -- In some versions of System.Aux_DEC, notably that for VMS on the
- -- ia64, there are two address types (64-bit and 32-bit), and the
- -- name Short_Address is used for the short address form. To avoid
- -- difficulties (in regression tests and elsewhere) with units that
- -- reference Short_Address, it is provided for other targets as a
- -- synonym for the normal Address type, and, as in the case where
- -- the lengths are different, Address and Short_Address can be
- -- freely inter-converted.
+ -- In some versions of System.Aux_DEC, notably that for VMS on IA64, there
+ -- are two address types (64-bit and 32-bit), and the name Short_Address
+ -- is used for the short address form. To avoid difficulties (in regression
+ -- tests and elsewhere) with units that reference Short_Address, it is
+ -- provided for other targets as a synonym for the normal Address type,
+ -- and, as in the case where the lengths are different, Address and
+ -- Short_Address can be freely inter-converted.
type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1;
for Integer_8'Size use 8;
pragma Import (Intrinsic, Import_Address);
pragma Import (Intrinsic, Import_Largest_Value);
- -- For the following declarations, note that the declaration without
- -- a Retry_Count parameter means to retry infinitely. A value of zero
- -- for the Retry_Count parameter means do not retry.
+ -- For the following declarations, note that the declaration without a
+ -- Retry_Count parameter means to retry infinitely. A value of zero for
+ -- the Retry_Count parameter means do not retry.
-- Interlocked-instruction procedures
Value : Short_Integer;
end record;
- for Aligned_Word'Alignment use
- Integer'Min (2, Standard'Maximum_Alignment);
+ for Aligned_Word'Alignment use Integer'Min (2, Standard'Maximum_Alignment);
procedure Clear_Interlocked
(Bit : in out Boolean;
for Aligned_Long_Integer'Alignment use
Integer'Min (8, Standard'Maximum_Alignment);
- -- For the following declarations, note that the declaration without
- -- a Retry_Count parameter mean to retry infinitely. A value of zero
- -- for the Retry_Count means do not retry.
+ -- For the following declarations, note that the declaration without a
+ -- Retry_Count parameter mean to retry infinitely. A value of zero for
+ -- the Retry_Count means do not retry.
procedure Add_Atomic
(To : in out Aligned_Integer;
Old_Value : out Long_Integer;
Success_Flag : out Boolean);
- type Insq_Status is
- (Fail_No_Lock, OK_Not_First, OK_First);
+ type Insq_Status is (Fail_No_Lock, OK_Not_First, OK_First);
for Insq_Status use
(Fail_No_Lock => -1,
- OK_Not_First => 0,
+ OK_Not_First => 0,
OK_First => +1);
type Remq_Status is (
for Remq_Status use
(Fail_No_Lock => -1,
- Fail_Was_Empty => 0,
+ Fail_Was_Empty => 0,
OK_Not_Empty => +1,
OK_Empty => +2);
No_Addr : constant Address := Null_Address;
-- 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
-- highly stylized. See body of System.AST_Handling for full details.
-- Note: do not introduce any pragma Inline statements into this unit, since
-- otherwise the relinking and rebinding capability would be deactivated.
-with System.Aux_DEC;
-
package System.Parameters is
pragma Pure;
-- of all targets. For example, in OpenVMS long /= Long_Integer.
ptr_bits : constant := 32;
- subtype C_Address is System.Short_Address;
- -- Number of bits in Interaces.C pointers, normally a standard 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 Interfaces.C pointers, normally a standard address,
-- 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";
-- Name of runtime function used to allocate such a pointer
-- Note: do not introduce any pragma Inline statements into this unit, since
-- otherwise the relinking and rebinding capability would be deactivated.
-with System.Aux_DEC;
-
package System.Parameters is
pragma Pure;
-- of all targets. For example, in OpenVMS long /= Long_Integer.
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,
-- except on 64-bit VMS where they are 32-bit addresses, for compatibility
-- with legacy code.
+ -- System.Aux_DEC.Short_Address can't be used because of elaboration
+ -- circularity.
C_Malloc_Linkname : constant String := "__gnat_malloc32";
-- Name of runtime function used to allocate such a pointer
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
begin
Set_Etype (N, Any_Type);
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,
- -- add it only if the else expression has a compatible type.
+ Set_Etype (N, Standard_Boolean);
+ 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
- Add_One_Interp (N, It.Typ, It.Typ);
- end if;
+ if Has_Compatible_Type (Else_Expr, It.Typ) then
+ Add_One_Interp (N, It.Typ, It.Typ);
+ end if;
- Get_Next_Interp (I, It);
- end loop;
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
end;
end if;
end Analyze_Conditional_Expression;
and then
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 =>
return
FCE (Low_Bound (E1), Low_Bound (E2))
pragma Assert (not Scope_Stack.Table (J).Is_Active_Stack_Base);
end loop;
- pragma Assert (False); -- unreachable
- raise Program_Error;
+ raise Program_Error; -- unreachable
end Has_Loop_In_Inner_Open_Scopes;
--------------------
projects / gcc.git / commitdiff