This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
committed: Ada updates
- From: Arnaud Charlet <charlet at ACT-Europe dot FR>
- To: gcc-patches at gcc dot gnu dot org
- Date: Thu, 27 Nov 2003 12:41:50 +0100
- Subject: committed: Ada updates
Tested on x86-linux
--
2003-11-26 Arnaud Charlet <charlet@act-europe.fr>
(Cond_Timed_Wait): Introduce new constant Time_Out_Max,
since NT 4 cannot handle timeout values that are too large,
e.g. DWORD'Last - 1.
2003-11-26 Ed Schonberg <schonberg@gnat.com>
* exp_ch4.adb:
(Expand_N_Slice): Recognize all cases of slices that appear as actuals
in procedure calls and whose expansion must be deferred.
* exp_ch6.adb (Add_Call_By_Copy_Node): Remove previous fix. Proper fix
is in exp_ch4.
* sem_ch3.adb:
(Build_Derived_Array_Type): Create operator for unconstrained type
if ancestor is unconstrained.
2003-11-26 Vincent Celier <celier@gnat.com>
* make.adb (Project_Object_Directory): New global variable
(Change_To_Object_Directory): New procedure
(Collect_Arguments_And_Compile): Call Change_To_Object_Directory instead
of Change_Dir directly. Do not change working directory to object
directory of main project after each compilation.
(Gnatmake): Use Change_To_Object_Directory instead of Change_Dir
directly.
Change to object directory of main project before binding step.
(Initialize): Initialize Project_Object_Directory to No_Project
* mlib-prj.adb:
(Build_Library): Take into account Builder'Default_Switches ("Ada") when
binding a Stand-Alone Library.
* output.adb: Update Copyright notice
(Write_Char): Output buffer when full
2003-11-26 Robert Dewar <dewar@gnat.com>
* sem_ch13.adb: (Check_Size): Reset size if size is too small
* sem_ch13.ads:
(Check_Size): Fix documentation to include bit-packed array case
* sem_res.adb: Implement restriction No_Direct_Boolean_Operators
* s-rident.ads: Put No_Direct_Boolean_Operators in proper order
* s-rident.ads: Add new restriction No_Direct_Boolean_Operators
2003-11-26 Thomas Quinot <quinot@act-europe.fr>
* g-socket.ads, g-socket.adb:
Clarify documentation of function Stream. Introduce a Free procedure
to release the returned Stream once it becomes unused.
* 5asystem.ads: For Alpha Tru64, enable ZCX by default.
--
Index: 5asystem.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5asystem.ads,v
retrieving revision 1.6
diff -u -p -r1.6 5asystem.ads
--- 5asystem.ads 21 Oct 2003 13:41:51 -0000 1.6
+++ 5asystem.ads 26 Nov 2003 09:04:24 -0000
@@ -138,8 +138,8 @@ private
Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := False;
- GCC_ZCX_Support : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False;
-- Obsolete entries, to be removed eventually (bootstrap issues!)
Index: 5wtaprop.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/5wtaprop.adb,v
retrieving revision 1.7
diff -u -p -r1.7 5wtaprop.adb
--- 5wtaprop.adb 21 Oct 2003 13:41:52 -0000 1.7
+++ 5wtaprop.adb 26 Nov 2003 09:04:25 -0000
@@ -296,9 +296,13 @@ package body System.Task_Primitives.Oper
Timed_Out : out Boolean;
Status : out Integer)
is
- Time_Out : DWORD;
- Result : BOOL;
- Wait_Result : DWORD;
+ Time_Out_Max : constant DWORD := 16#FFFF0000#;
+ -- NT 4 cannot handle timeout values that are too large,
+ -- e.g. DWORD'Last - 1
+
+ Time_Out : DWORD;
+ Result : BOOL;
+ Wait_Result : DWORD;
begin
-- Must reset Cond BEFORE L is unlocked.
@@ -315,8 +319,8 @@ package body System.Task_Primitives.Oper
Wait_Result := 0;
else
- if Rel_Time >= Duration (DWORD'Last - 1) / 1000 then
- Time_Out := DWORD'Last - 1;
+ if Rel_Time >= Duration (Time_Out_Max) / 1000 then
+ Time_Out := Time_Out_Max;
else
Time_Out := DWORD (Rel_Time * 1000);
end if;
Index: exp_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch4.adb,v
retrieving revision 1.11
diff -u -p -r1.11 exp_ch4.adb
--- exp_ch4.adb 24 Nov 2003 14:27:57 -0000 1.11
+++ exp_ch4.adb 26 Nov 2003 09:04:26 -0000
@@ -5333,11 +5333,36 @@ package body Exp_Ch4 is
Pfx : constant Node_Id := Prefix (N);
Ptp : Entity_Id := Etype (Pfx);
+ function Is_Procedure_Actual (N : Node_Id) return Boolean;
+ -- Check whether context is a procedure call, in which case
+ -- expansion of a bit-packed slice is deferred until the call
+ -- itself is expanded.
+
procedure Make_Temporary;
-- Create a named variable for the value of the slice, in
-- cases where the back-end cannot handle it properly, e.g.
-- when packed types or unaligned slices are involved.
+ -------------------------
+ -- Is_Procedure_Actual --
+ -------------------------
+
+ function Is_Procedure_Actual (N : Node_Id) return Boolean is
+ Par : Node_Id := Parent (N);
+ begin
+ while Present (Par)
+ and then Nkind (Par) not in N_Statement_Other_Than_Procedure_Call
+ loop
+ if Nkind (Par) = N_Procedure_Call_Statement then
+ return True;
+ else
+ Par := Parent (Par);
+ end if;
+ end loop;
+
+ return False;
+ end Is_Procedure_Actual;
+
--------------------
-- Make_Temporary --
--------------------
@@ -5422,26 +5447,34 @@ package body Exp_Ch4 is
-- is caught elsewhere, and the expansion would intefere
-- with generating the error message).
- if Is_Packed (Typ)
- and then Nkind (Parent (N)) /= N_Assignment_Statement
- and then (Nkind (Parent (Parent (N))) /= N_Assignment_Statement
- or else
- Parent (N) /= Name (Parent (Parent (N))))
- and then Nkind (Parent (N)) /= N_Indexed_Component
- and then not Is_Renamed_Object (N)
- and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
- and then (Nkind (Parent (N)) /= N_Attribute_Reference
- or else
- Attribute_Name (Parent (N)) /= Name_Address)
+ if not Is_Packed (Typ) then
+ -- apply transformation for actuals of a function call, where
+ -- Expand_Actuals is not used.
+
+ if Nkind (Parent (N)) = N_Function_Call
+ and then Is_Possibly_Unaligned_Slice (N)
+ then
+ Make_Temporary;
+ end if;
+
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
+ or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
+ and then Parent (N) = Name (Parent (Parent (N))))
then
- Make_Temporary;
+ return;
- -- Same transformation for actuals in a function call, where
- -- Expand_Actuals is not used.
+ elsif Nkind (Parent (N)) = N_Indexed_Component
+ or else Is_Renamed_Object (N)
+ or else Is_Procedure_Actual (N)
+ then
+ return;
- elsif Nkind (Parent (N)) = N_Function_Call
- and then Is_Possibly_Unaligned_Slice (N)
+ elsif (Nkind (Parent (N)) = N_Attribute_Reference
+ and then Attribute_Name (Parent (N)) = Name_Address)
then
+ return;
+
+ else
Make_Temporary;
end if;
end Expand_N_Slice;
Index: exp_ch6.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch6.adb,v
retrieving revision 1.12
diff -u -p -r1.12 exp_ch6.adb
--- exp_ch6.adb 20 Nov 2003 09:53:58 -0000 1.12
+++ exp_ch6.adb 26 Nov 2003 09:04:26 -0000
@@ -544,24 +544,8 @@ package body Exp_Ch6 is
-- If the formal is an (in-)out parameter, capture the name
-- of the variable in order to build the post-call assignment.
- -- The variable itself may have been expanded, for example if
- -- it is a complex bit-packed array, so we need to recover the
- -- original to ensure that we have the proper target for the
- -- assignment. Examine the slocs of the two nodes to determine
- -- whether the rewriting is an expansion, or a substitution done
- -- on an inlined body, in which case it must be respected.
- declare
- Orig : constant Node_Id := Original_Node (Expression (Actual));
- begin
- if Orig /= Expression (Actual)
- and then Sloc (Orig) = Sloc (Expression (Actual))
- then
- Var := Make_Var (Orig);
- else
- Var := Make_Var (Expression (Actual));
- end if;
- end;
+ Var := Make_Var (Expression (Actual));
Crep := not Same_Representation
(Etype (Formal), Etype (Expression (Actual)));
Index: g-socket.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-socket.adb,v
retrieving revision 1.6
diff -u -p -r1.6 g-socket.adb
--- g-socket.adb 21 Oct 2003 13:42:05 -0000 1.6
+++ g-socket.adb 26 Nov 2003 09:04:26 -0000
@@ -34,6 +34,7 @@
with Ada.Streams; use Ada.Streams;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
with Interfaces.C.Strings;
@@ -776,6 +777,17 @@ package body GNAT.Sockets is
Thin.Finalize;
end if;
end Finalize;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Stream : in out Stream_Access) is
+ procedure Do_Free is new Ada.Unchecked_Deallocation
+ (Ada.Streams.Root_Stream_Type'Class, Stream_Access);
+ begin
+ Do_Free (Stream);
+ end Free;
---------
-- Get --
Index: g-socket.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-socket.ads,v
retrieving revision 1.7
diff -u -p -r1.7 g-socket.ads
--- g-socket.ads 21 Oct 2003 13:42:05 -0000 1.7
+++ g-socket.ads 26 Nov 2003 09:04:26 -0000
@@ -885,15 +885,15 @@ package GNAT.Sockets is
function Stream
(Socket : Socket_Type)
return Stream_Access;
- -- Associate a stream with a stream-based socket that is already
- -- connected.
+ -- Create a stream associated with a stream-based socket that is
+ -- already connected.
function Stream
(Socket : Socket_Type;
Send_To : Sock_Addr_Type)
return Stream_Access;
- -- Associate a stream with a datagram-based socket that is already
- -- bound. Send_To is the socket address to which messages are
+ -- Create a stream associated with a datagram-based socket that is
+ -- already bound. Send_To is the socket address to which messages are
-- being sent.
function Get_Address
@@ -901,6 +901,11 @@ package GNAT.Sockets is
return Sock_Addr_Type;
-- Return the socket address from which the last message was
-- received.
+
+ procedure Free (Stream : in out Stream_Access);
+ -- Destroy a stream created by one of the Stream functions above, and
+ -- release associated resources. The user is responsible for calling
+ -- this subprogram when the stream is not needed anymore.
type Socket_Set_Type is limited private;
-- This type allows to manipulate sets of sockets. It allows to
Index: make.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/make.adb,v
retrieving revision 1.25
diff -u -p -r1.25 make.adb
--- make.adb 24 Nov 2003 14:27:57 -0000 1.25
+++ make.adb 26 Nov 2003 09:04:27 -0000
@@ -312,6 +312,11 @@ package body Make is
Main_Project : Prj.Project_Id := No_Project;
-- The project id of the main project file, if any
+ Project_Object_Directory : Project_Id := No_Project;
+ -- The object directory of the project for the last compilation.
+ -- Avoid calling Change_Dir if the current working directory is already
+ -- this directory
+
-- Packages of project files where unknown attributes are errors.
Naming_String : aliased String := "naming";
@@ -344,6 +349,10 @@ package body Make is
procedure Add_Object_Directories is
new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir);
+ procedure Change_To_Object_Directory (Project : Project_Id);
+ -- Change to the object directory of project Project, if this is not
+ -- already the current working directory.
+
type Bad_Compilation_Info is record
File : File_Name_Type;
Unit : Unit_Name_Type;
@@ -1107,6 +1116,36 @@ package body Make is
end if;
end Bind;
+ --------------------------------
+ -- Change_To_Object_Directory --
+ --------------------------------
+
+ procedure Change_To_Object_Directory (Project : Project_Id) is
+ begin
+ -- Nothing to do if the current working directory is alresdy the one
+ -- we want.
+
+ if Project_Object_Directory /= Project then
+ Project_Object_Directory := Project;
+
+ -- If in a real project, set the working directory to the object
+ -- directory of the project.
+
+ if Project /= No_Project then
+ Change_Dir
+ (Get_Name_String (Projects.Table (Project).Object_Directory));
+
+ -- Otherwise, for sources outside of any project, set the working
+ -- directory to the object directory of the main project.
+
+ elsif Main_Project /= No_Project then
+ Change_Dir
+ (Get_Name_String
+ (Projects.Table (Main_Project).Object_Directory));
+ end if;
+ end if;
+ end Change_To_Object_Directory;
+
-----------
-- Check --
-----------
@@ -2204,28 +2243,23 @@ package body Make is
end;
end if;
- -- Change to the object directory of the project file, if it is
- -- not the main project file.
+ -- Change to the object directory of the project file,
+ -- if necessary.
- if Arguments_Project /= Main_Project then
- Change_Dir
- (Get_Name_String
- (Projects.Table (Arguments_Project).Object_Directory));
- end if;
+ Change_To_Object_Directory (Arguments_Project);
Pid := Compile (Arguments_Path_Name, Lib_File,
Arguments (1 .. Last_Argument));
- -- Change back to the object directory of the main project file,
- -- if necessary.
+ else
+ -- If this is a source outside of any project file, make sure
+ -- it will be compiled in the object directory of the main project
+ -- file.
- if Arguments_Project /= Main_Project then
- Change_Dir
- (Get_Name_String
- (Projects.Table (Main_Project).Object_Directory));
+ if Main_Project /= No_Project then
+ Change_To_Object_Directory (Arguments_Project);
end if;
- else
Pid := Compile (Full_Source_File, Lib_File,
Arguments (1 .. Last_Argument));
end if;
@@ -3761,9 +3795,8 @@ package body Make is
-- project.
begin
- Change_Dir
- (Get_Name_String
- (Projects.Table (Main_Project).Object_Directory));
+ Project_Object_Directory := No_Project;
+ Change_To_Object_Directory (Main_Project);
exception
when Directory_Error =>
@@ -4623,6 +4656,13 @@ package body Make is
end Recursive_Compilation_Step;
end if;
+ -- For binding and linking, we need to be in the object directory of
+ -- the main project.
+
+ if Main_Project /= No_Project then
+ Change_To_Object_Directory (Main_Project);
+ end if;
+
-- If we are here, it means that we need to rebuilt the current
-- main. So we set Executable_Obsolete to True to make sure that
-- the subsequent mains will be rebuilt.
@@ -5712,6 +5752,10 @@ package body Make is
Make_Failed (Exception_Message (Err));
end;
end if;
+
+ -- Make sure no project object directory is recorded
+
+ Project_Object_Directory := No_Project;
-- Set the marking label to a value that is not zero
Index: mlib-prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/mlib-prj.adb,v
retrieving revision 1.5
diff -u -p -r1.5 mlib-prj.adb
--- mlib-prj.adb 20 Nov 2003 09:54:00 -0000 1.5
+++ mlib-prj.adb 26 Nov 2003 09:04:27 -0000
@@ -806,6 +806,42 @@ package body MLib.Prj is
(B_Start & Get_Name_String (Data.Library_Name) & ".adb");
Add_Argument ("-L" & Get_Name_String (Data.Library_Name));
+ -- Check if Binder'Default_Switches ("Ada) is defined. If it is,
+ -- add these switches to call gnatbind.
+
+ declare
+ Binder_Package : constant Package_Id :=
+ Value_Of
+ (Name => Name_Binder,
+ In_Packages => Data.Decl.Packages);
+ begin
+ if Binder_Package /= No_Package then
+ declare
+ Defaults : constant Array_Element_Id :=
+ Value_Of
+ (Name => Name_Default_Switches,
+ In_Arrays =>
+ Packages.Table
+ (Binder_Package).Decl.Arrays);
+ Switches : Variable_Value :=
+ Value_Of
+ (Index => Name_Ada, In_Array => Defaults);
+ Switch : String_List_Id := Nil_String;
+ begin
+ if not Switches.Default then
+ Switch := Switches.Values;
+
+ while Switch /= Nil_String loop
+ Add_Argument
+ (Get_Name_String
+ (String_Elements.Table (Switch).Value));
+ Switch := String_Elements.Table (Switch).Next;
+ end loop;
+ end if;
+ end;
+ end if;
+ end;
+
-- Get all the ALI files of the project file
declare
Index: output.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/output.adb,v
retrieving revision 1.5
diff -u -p -r1.5 output.adb
--- output.adb 24 Apr 2003 17:54:07 -0000 1.5
+++ output.adb 26 Nov 2003 09:04:27 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, 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- --
@@ -236,10 +236,12 @@ package body Output is
procedure Write_Char (C : Character) is
begin
- if Next_Column < Buffer'Length then
- Buffer (Natural (Next_Column)) := C;
- Next_Column := Next_Column + 1;
+ if Next_Column = Buffer'Length then
+ Write_Eol;
end if;
+
+ Buffer (Natural (Next_Column)) := C;
+ Next_Column := Next_Column + 1;
end Write_Char;
---------------
Index: sem_ch13.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch13.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_ch13.adb
--- sem_ch13.adb 17 Nov 2003 14:58:16 -0000 1.11
+++ sem_ch13.adb 26 Nov 2003 09:04:27 -0000
@@ -2898,6 +2898,8 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := Asiz;
Error_Msg_NE
("size for& too small, minimum allowed is ^", N, T);
+ Set_Esize (T, Asiz);
+ Set_RM_Size (T, Asiz);
end if;
end;
@@ -2939,6 +2941,8 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := M;
Error_Msg_NE
("size for& too small, minimum allowed is ^", N, T);
+ Set_Esize (T, M);
+ Set_RM_Size (T, M);
else
Biased := True;
end if;
Index: sem_ch13.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch13.ads,v
retrieving revision 1.6
diff -u -p -r1.6 sem_ch13.ads
--- sem_ch13.ads 21 Oct 2003 13:42:19 -0000 1.6
+++ sem_ch13.ads 26 Nov 2003 09:04:27 -0000
@@ -79,14 +79,17 @@ package Sem_Ch13 is
Biased : out Boolean);
-- Called when size Siz is specified for subtype T. This subprogram checks
-- that the size is appropriate, posting errors on node N as required.
- -- For non-elementary types, a check is only made if an explicit size
- -- has been given for the type (and the specified size must match). The
- -- parameter Biased is set False if the size specified did not require
+ -- This check is effective for elementary types and bit-packed arrays.
+ -- For other non-elementary types, a check is only made if an explicit
+ -- size has been given for the type (and the specified size must match).
+ -- The parameter Biased is set False if the size specified did not require
-- the use of biased representation, and True if biased representation
-- was required to meet the size requirement. Note that Biased is only
-- set if the type is not currently biased, but biasing it is the only
-- way to meet the requirement. If the type is currently biased, then
-- this biased size is used in the initial check, and Biased is False.
+ -- If the size is too small, and an error message is given, then both
+ -- Esize and RM_Size are reset to the allowed minimum value in T.
procedure Record_Rep_Item (T : Entity_Id; N : Node_Id);
-- N is the node for either a representation pragma or an attribute
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.23
diff -u -p -r1.23 sem_ch3.adb
--- sem_ch3.adb 24 Nov 2003 14:27:57 -0000 1.23
+++ sem_ch3.adb 26 Nov 2003 09:04:28 -0000
@@ -3061,14 +3061,21 @@ package body Sem_Ch3 is
-- declared in a closed scope (e.g., a subprogram), then we
-- need to explicitly introduce the new type's concatenation
-- operator since Derive_Subprograms will not inherit the
- -- parent's operator.
+ -- parent's operator. If the parent type is unconstrained, the
+ -- operator is of the unconstrained base type.
if Number_Dimensions (Parent_Type) = 1
and then not Is_Limited_Type (Parent_Type)
and then not Is_Derived_Type (Parent_Type)
and then not Is_Package (Scope (Base_Type (Parent_Type)))
then
- New_Concatenation_Op (Derived_Type);
+ if not Is_Constrained (Parent_Type)
+ and then Is_Constrained (Derived_Type)
+ then
+ New_Concatenation_Op (Implicit_Base);
+ else
+ New_Concatenation_Op (Derived_Type);
+ end if;
end if;
end Build_Derived_Array_Type;
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.13
diff -u -p -r1.13 sem_res.adb
--- sem_res.adb 14 Nov 2003 10:24:43 -0000 1.13
+++ sem_res.adb 26 Nov 2003 09:04:28 -0000
@@ -88,6 +88,11 @@ package body Sem_Res is
-- Give list of candidate interpretations when a character literal cannot
-- be resolved.
+ procedure Check_Direct_Boolean_Op (N : Node_Id);
+ -- N is a binary operator node which may possibly operate on Boolean
+ -- operands. If the operator does have Boolean operands, then a call is
+ -- made to check the restriction No_Direct_Boolean_Operators.
+
procedure Check_Discriminant_Use (N : Node_Id);
-- Enforce the restrictions on the use of discriminants when constraining
-- a component of a discriminated type (record or concurrent type).
@@ -342,6 +347,17 @@ package body Sem_Res is
end if;
end Analyze_And_Resolve;
+ -----------------------------
+ -- Check_Direct_Boolean_Op --
+ -----------------------------
+
+ procedure Check_Direct_Boolean_Op (N : Node_Id) is
+ begin
+ if Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean then
+ Check_Restriction (No_Direct_Boolean_Operators, N);
+ end if;
+ end Check_Direct_Boolean_Op;
+
----------------------------
-- Check_Discriminant_Use --
----------------------------
@@ -3852,6 +3868,8 @@ package body Sem_Res is
T : Entity_Id;
begin
+ Check_Direct_Boolean_Op (N);
+
-- If this is an intrinsic operation which is not predefined, use
-- the types of its declared arguments to resolve the possibly
-- overloaded operands. Otherwise the operands are unambiguous and
@@ -4591,6 +4609,8 @@ package body Sem_Res is
-- Start of processing for Resolve_Equality_Op
begin
+ Check_Direct_Boolean_Op (N);
+
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
@@ -4972,6 +4992,8 @@ package body Sem_Res is
B_Typ : Entity_Id;
begin
+ Check_Direct_Boolean_Op (N);
+
-- Predefined operations on scalar types yield the base type. On
-- the other hand, logical operations on arrays yield the type of
-- the arguments (and the context).
Index: s-rident.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-rident.ads,v
retrieving revision 1.1
diff -u -p -r1.1 s-rident.ads
--- s-rident.ads 21 Oct 2003 13:42:14 -0000 1.1
+++ s-rident.ads 26 Nov 2003 09:04:28 -0000
@@ -56,6 +56,7 @@ package System.Rident is
No_Asynchronous_Control, -- (RM D.7(10))
No_Calendar, -- GNAT
No_Delay, -- (RM H.4(21))
+ No_Direct_Boolean_Operators, -- GNAT
No_Dispatch, -- (RM H.4(19))
No_Dynamic_Interrupts, -- GNAT
No_Dynamic_Priorities, -- (RM D.9(9))