Commit 81a5b587 by Arnaud Charlet

[multiple changes]

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.

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

From-SVN: r73991
parent f4314bb6
...@@ -138,8 +138,8 @@ private ...@@ -138,8 +138,8 @@ private
Support_Long_Shifts : constant Boolean := True; Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False; ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := False; GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False;
-- Obsolete entries, to be removed eventually (bootstrap issues!) -- Obsolete entries, to be removed eventually (bootstrap issues!)
......
...@@ -296,9 +296,13 @@ package body System.Task_Primitives.Operations is ...@@ -296,9 +296,13 @@ package body System.Task_Primitives.Operations is
Timed_Out : out Boolean; Timed_Out : out Boolean;
Status : out Integer) Status : out Integer)
is is
Time_Out : DWORD; Time_Out_Max : constant DWORD := 16#FFFF0000#;
Result : BOOL; -- NT 4 cannot handle timeout values that are too large,
Wait_Result : DWORD; -- e.g. DWORD'Last - 1
Time_Out : DWORD;
Result : BOOL;
Wait_Result : DWORD;
begin begin
-- Must reset Cond BEFORE L is unlocked. -- Must reset Cond BEFORE L is unlocked.
...@@ -315,8 +319,8 @@ package body System.Task_Primitives.Operations is ...@@ -315,8 +319,8 @@ package body System.Task_Primitives.Operations is
Wait_Result := 0; Wait_Result := 0;
else else
if Rel_Time >= Duration (DWORD'Last - 1) / 1000 then if Rel_Time >= Duration (Time_Out_Max) / 1000 then
Time_Out := DWORD'Last - 1; Time_Out := Time_Out_Max;
else else
Time_Out := DWORD (Rel_Time * 1000); Time_Out := DWORD (Rel_Time * 1000);
end if; end if;
......
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.
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-24 Arnaud Charlet <charlet@act-europe.fr> 2003-11-24 Arnaud Charlet <charlet@act-europe.fr>
PR ada/13142 PR ada/13142
......
...@@ -5333,11 +5333,36 @@ package body Exp_Ch4 is ...@@ -5333,11 +5333,36 @@ package body Exp_Ch4 is
Pfx : constant Node_Id := Prefix (N); Pfx : constant Node_Id := Prefix (N);
Ptp : Entity_Id := Etype (Pfx); 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; procedure Make_Temporary;
-- Create a named variable for the value of the slice, in -- Create a named variable for the value of the slice, in
-- cases where the back-end cannot handle it properly, e.g. -- cases where the back-end cannot handle it properly, e.g.
-- when packed types or unaligned slices are involved. -- 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 -- -- Make_Temporary --
-------------------- --------------------
...@@ -5422,26 +5447,34 @@ package body Exp_Ch4 is ...@@ -5422,26 +5447,34 @@ package body Exp_Ch4 is
-- is caught elsewhere, and the expansion would intefere -- is caught elsewhere, and the expansion would intefere
-- with generating the error message). -- with generating the error message).
if Is_Packed (Typ) if not Is_Packed (Typ) then
and then Nkind (Parent (N)) /= N_Assignment_Statement -- apply transformation for actuals of a function call, where
and then (Nkind (Parent (Parent (N))) /= N_Assignment_Statement -- Expand_Actuals is not used.
or else
Parent (N) /= Name (Parent (Parent (N)))) if Nkind (Parent (N)) = N_Function_Call
and then Nkind (Parent (N)) /= N_Indexed_Component and then Is_Possibly_Unaligned_Slice (N)
and then not Is_Renamed_Object (N) then
and then Nkind (Parent (N)) /= N_Procedure_Call_Statement Make_Temporary;
and then (Nkind (Parent (N)) /= N_Attribute_Reference end if;
or else
Attribute_Name (Parent (N)) /= Name_Address) 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 then
Make_Temporary; return;
-- Same transformation for actuals in a function call, where elsif Nkind (Parent (N)) = N_Indexed_Component
-- Expand_Actuals is not used. or else Is_Renamed_Object (N)
or else Is_Procedure_Actual (N)
then
return;
elsif Nkind (Parent (N)) = N_Function_Call elsif (Nkind (Parent (N)) = N_Attribute_Reference
and then Is_Possibly_Unaligned_Slice (N) and then Attribute_Name (Parent (N)) = Name_Address)
then then
return;
else
Make_Temporary; Make_Temporary;
end if; end if;
end Expand_N_Slice; end Expand_N_Slice;
......
...@@ -544,24 +544,8 @@ package body Exp_Ch6 is ...@@ -544,24 +544,8 @@ package body Exp_Ch6 is
-- If the formal is an (in-)out parameter, capture the name -- If the formal is an (in-)out parameter, capture the name
-- of the variable in order to build the post-call assignment. -- 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 Var := Make_Var (Expression (Actual));
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;
Crep := not Same_Representation Crep := not Same_Representation
(Etype (Formal), Etype (Expression (Actual))); (Etype (Formal), Etype (Expression (Actual)));
......
...@@ -34,6 +34,7 @@ ...@@ -34,6 +34,7 @@
with Ada.Streams; use Ada.Streams; with Ada.Streams; use Ada.Streams;
with Ada.Exceptions; use Ada.Exceptions; with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion; with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces.C.Strings; with Interfaces.C.Strings;
...@@ -777,6 +778,17 @@ package body GNAT.Sockets is ...@@ -777,6 +778,17 @@ package body GNAT.Sockets is
end if; end if;
end Finalize; 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 -- -- Get --
--------- ---------
......
...@@ -885,15 +885,15 @@ package GNAT.Sockets is ...@@ -885,15 +885,15 @@ package GNAT.Sockets is
function Stream function Stream
(Socket : Socket_Type) (Socket : Socket_Type)
return Stream_Access; return Stream_Access;
-- Associate a stream with a stream-based socket that is already -- Create a stream associated with a stream-based socket that is
-- connected. -- already connected.
function Stream function Stream
(Socket : Socket_Type; (Socket : Socket_Type;
Send_To : Sock_Addr_Type) Send_To : Sock_Addr_Type)
return Stream_Access; return Stream_Access;
-- Associate a stream with a datagram-based socket that is already -- Create a stream associated with a datagram-based socket that is
-- bound. Send_To is the socket address to which messages are -- already bound. Send_To is the socket address to which messages are
-- being sent. -- being sent.
function Get_Address function Get_Address
...@@ -902,6 +902,11 @@ package GNAT.Sockets is ...@@ -902,6 +902,11 @@ package GNAT.Sockets is
-- Return the socket address from which the last message was -- Return the socket address from which the last message was
-- received. -- 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; type Socket_Set_Type is limited private;
-- This type allows to manipulate sets of sockets. It allows to -- This type allows to manipulate sets of sockets. It allows to
-- wait for events on multiple endpoints at one time. This is an -- wait for events on multiple endpoints at one time. This is an
......
...@@ -312,6 +312,11 @@ package body Make is ...@@ -312,6 +312,11 @@ package body Make is
Main_Project : Prj.Project_Id := No_Project; Main_Project : Prj.Project_Id := No_Project;
-- The project id of the main project file, if any -- 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. -- Packages of project files where unknown attributes are errors.
Naming_String : aliased String := "naming"; Naming_String : aliased String := "naming";
...@@ -344,6 +349,10 @@ package body Make is ...@@ -344,6 +349,10 @@ package body Make is
procedure Add_Object_Directories is procedure Add_Object_Directories is
new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir); 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 type Bad_Compilation_Info is record
File : File_Name_Type; File : File_Name_Type;
Unit : Unit_Name_Type; Unit : Unit_Name_Type;
...@@ -1107,6 +1116,36 @@ package body Make is ...@@ -1107,6 +1116,36 @@ package body Make is
end if; end if;
end Bind; 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 -- -- Check --
----------- -----------
...@@ -2204,28 +2243,23 @@ package body Make is ...@@ -2204,28 +2243,23 @@ package body Make is
end; end;
end if; end if;
-- Change to the object directory of the project file, if it is -- Change to the object directory of the project file,
-- not the main project file. -- if necessary.
if Arguments_Project /= Main_Project then Change_To_Object_Directory (Arguments_Project);
Change_Dir
(Get_Name_String
(Projects.Table (Arguments_Project).Object_Directory));
end if;
Pid := Compile (Arguments_Path_Name, Lib_File, Pid := Compile (Arguments_Path_Name, Lib_File,
Arguments (1 .. Last_Argument)); Arguments (1 .. Last_Argument));
-- Change back to the object directory of the main project file, else
-- if necessary. -- 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 if Main_Project /= No_Project then
Change_Dir Change_To_Object_Directory (Arguments_Project);
(Get_Name_String
(Projects.Table (Main_Project).Object_Directory));
end if; end if;
else
Pid := Compile (Full_Source_File, Lib_File, Pid := Compile (Full_Source_File, Lib_File,
Arguments (1 .. Last_Argument)); Arguments (1 .. Last_Argument));
end if; end if;
...@@ -3761,9 +3795,8 @@ package body Make is ...@@ -3761,9 +3795,8 @@ package body Make is
-- project. -- project.
begin begin
Change_Dir Project_Object_Directory := No_Project;
(Get_Name_String Change_To_Object_Directory (Main_Project);
(Projects.Table (Main_Project).Object_Directory));
exception exception
when Directory_Error => when Directory_Error =>
...@@ -4623,6 +4656,13 @@ package body Make is ...@@ -4623,6 +4656,13 @@ package body Make is
end Recursive_Compilation_Step; end Recursive_Compilation_Step;
end if; 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 -- 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 -- main. So we set Executable_Obsolete to True to make sure that
-- the subsequent mains will be rebuilt. -- the subsequent mains will be rebuilt.
...@@ -5713,6 +5753,10 @@ package body Make is ...@@ -5713,6 +5753,10 @@ package body Make is
end; end;
end if; 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 -- Set the marking label to a value that is not zero
Marking_Label := 1; Marking_Label := 1;
......
...@@ -806,6 +806,42 @@ package body MLib.Prj is ...@@ -806,6 +806,42 @@ package body MLib.Prj is
(B_Start & Get_Name_String (Data.Library_Name) & ".adb"); (B_Start & Get_Name_String (Data.Library_Name) & ".adb");
Add_Argument ("-L" & Get_Name_String (Data.Library_Name)); 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 -- Get all the ALI files of the project file
declare declare
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- --
...@@ -236,10 +236,12 @@ package body Output is ...@@ -236,10 +236,12 @@ package body Output is
procedure Write_Char (C : Character) is procedure Write_Char (C : Character) is
begin begin
if Next_Column < Buffer'Length then if Next_Column = Buffer'Length then
Buffer (Natural (Next_Column)) := C; Write_Eol;
Next_Column := Next_Column + 1;
end if; end if;
Buffer (Natural (Next_Column)) := C;
Next_Column := Next_Column + 1;
end Write_Char; end Write_Char;
--------------- ---------------
......
...@@ -56,6 +56,7 @@ package System.Rident is ...@@ -56,6 +56,7 @@ package System.Rident is
No_Asynchronous_Control, -- (RM D.7(10)) No_Asynchronous_Control, -- (RM D.7(10))
No_Calendar, -- GNAT No_Calendar, -- GNAT
No_Delay, -- (RM H.4(21)) No_Delay, -- (RM H.4(21))
No_Direct_Boolean_Operators, -- GNAT
No_Dispatch, -- (RM H.4(19)) No_Dispatch, -- (RM H.4(19))
No_Dynamic_Interrupts, -- GNAT No_Dynamic_Interrupts, -- GNAT
No_Dynamic_Priorities, -- (RM D.9(9)) No_Dynamic_Priorities, -- (RM D.9(9))
......
...@@ -2898,6 +2898,8 @@ package body Sem_Ch13 is ...@@ -2898,6 +2898,8 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := Asiz; Error_Msg_Uint_1 := Asiz;
Error_Msg_NE Error_Msg_NE
("size for& too small, minimum allowed is ^", N, T); ("size for& too small, minimum allowed is ^", N, T);
Set_Esize (T, Asiz);
Set_RM_Size (T, Asiz);
end if; end if;
end; end;
...@@ -2939,6 +2941,8 @@ package body Sem_Ch13 is ...@@ -2939,6 +2941,8 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := M; Error_Msg_Uint_1 := M;
Error_Msg_NE Error_Msg_NE
("size for& too small, minimum allowed is ^", N, T); ("size for& too small, minimum allowed is ^", N, T);
Set_Esize (T, M);
Set_RM_Size (T, M);
else else
Biased := True; Biased := True;
end if; end if;
......
...@@ -79,14 +79,17 @@ package Sem_Ch13 is ...@@ -79,14 +79,17 @@ package Sem_Ch13 is
Biased : out Boolean); Biased : out Boolean);
-- Called when size Siz is specified for subtype T. This subprogram checks -- Called when size Siz is specified for subtype T. This subprogram checks
-- that the size is appropriate, posting errors on node N as required. -- 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 -- This check is effective for elementary types and bit-packed arrays.
-- has been given for the type (and the specified size must match). The -- For other non-elementary types, a check is only made if an explicit
-- parameter Biased is set False if the size specified did not require -- 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 -- the use of biased representation, and True if biased representation
-- was required to meet the size requirement. Note that Biased is only -- 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 -- 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 -- 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. -- 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); procedure Record_Rep_Item (T : Entity_Id; N : Node_Id);
-- N is the node for either a representation pragma or an attribute -- N is the node for either a representation pragma or an attribute
......
...@@ -3061,14 +3061,21 @@ package body Sem_Ch3 is ...@@ -3061,14 +3061,21 @@ package body Sem_Ch3 is
-- declared in a closed scope (e.g., a subprogram), then we -- declared in a closed scope (e.g., a subprogram), then we
-- need to explicitly introduce the new type's concatenation -- need to explicitly introduce the new type's concatenation
-- operator since Derive_Subprograms will not inherit the -- 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 if Number_Dimensions (Parent_Type) = 1
and then not Is_Limited_Type (Parent_Type) and then not Is_Limited_Type (Parent_Type)
and then not Is_Derived_Type (Parent_Type) and then not Is_Derived_Type (Parent_Type)
and then not Is_Package (Scope (Base_Type (Parent_Type))) and then not Is_Package (Scope (Base_Type (Parent_Type)))
then 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 if;
end Build_Derived_Array_Type; end Build_Derived_Array_Type;
......
...@@ -88,6 +88,11 @@ package body Sem_Res is ...@@ -88,6 +88,11 @@ package body Sem_Res is
-- Give list of candidate interpretations when a character literal cannot -- Give list of candidate interpretations when a character literal cannot
-- be resolved. -- 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); procedure Check_Discriminant_Use (N : Node_Id);
-- Enforce the restrictions on the use of discriminants when constraining -- Enforce the restrictions on the use of discriminants when constraining
-- a component of a discriminated type (record or concurrent type). -- a component of a discriminated type (record or concurrent type).
...@@ -342,6 +347,17 @@ package body Sem_Res is ...@@ -342,6 +347,17 @@ package body Sem_Res is
end if; end if;
end Analyze_And_Resolve; 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 -- -- Check_Discriminant_Use --
---------------------------- ----------------------------
...@@ -3852,6 +3868,8 @@ package body Sem_Res is ...@@ -3852,6 +3868,8 @@ package body Sem_Res is
T : Entity_Id; T : Entity_Id;
begin begin
Check_Direct_Boolean_Op (N);
-- If this is an intrinsic operation which is not predefined, use -- If this is an intrinsic operation which is not predefined, use
-- the types of its declared arguments to resolve the possibly -- the types of its declared arguments to resolve the possibly
-- overloaded operands. Otherwise the operands are unambiguous and -- overloaded operands. Otherwise the operands are unambiguous and
...@@ -4591,6 +4609,8 @@ package body Sem_Res is ...@@ -4591,6 +4609,8 @@ package body Sem_Res is
-- Start of processing for Resolve_Equality_Op -- Start of processing for Resolve_Equality_Op
begin begin
Check_Direct_Boolean_Op (N);
Set_Etype (N, Base_Type (Typ)); Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' '); Generate_Reference (T, N, ' ');
...@@ -4972,6 +4992,8 @@ package body Sem_Res is ...@@ -4972,6 +4992,8 @@ package body Sem_Res is
B_Typ : Entity_Id; B_Typ : Entity_Id;
begin begin
Check_Direct_Boolean_Op (N);
-- Predefined operations on scalar types yield the base type. On -- Predefined operations on scalar types yield the base type. On
-- the other hand, logical operations on arrays yield the type of -- the other hand, logical operations on arrays yield the type of
-- the arguments (and the context). -- the arguments (and the context).
......
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