OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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
This commit is contained in:
Arnaud Charlet 2003-11-27 12:40:45 +01:00
parent f4314bb628
commit 81a5b587ef
15 changed files with 287 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/5asystem.ads
View File

@ -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!)

14
gcc/ada/5wtaprop.adb
View File

@ -296,9 +296,13 @@ package body System.Task_Primitives.Operations is
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.Operations is
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;

59
gcc/ada/ChangeLog
View File

@ -1,3 +1,62 @@
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>
PR ada/13142

67
gcc/ada/exp_ch4.adb
View File

@ -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)
then
Make_Temporary;
if not Is_Packed (Typ) then
-- apply transformation for actuals of a function call, where
-- Expand_Actuals is not used.
-- Same transformation for actuals in 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_Function_Call
and then Is_Possibly_Unaligned_Slice (N)
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
return;
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_Attribute_Reference
and then Attribute_Name (Parent (N)) = Name_Address)
then
return;
else
Make_Temporary;
end if;
end Expand_N_Slice;

18
gcc/ada/exp_ch6.adb
View File

@ -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)));

12
gcc/ada/g-socket.adb
View File

@ -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;
@ -777,6 +778,17 @@ package body GNAT.Sockets is
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 --
---------

13
gcc/ada/g-socket.ads
View File

@ -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
@ -902,6 +902,11 @@ package GNAT.Sockets is
-- 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
-- wait for events on multiple endpoints at one time. This is an

78
gcc/ada/make.adb
View File

@ -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.
@ -5713,6 +5753,10 @@ package body Make is
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
Marking_Label := 1;

36
gcc/ada/mlib-prj.adb
View File

@ -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

10
gcc/ada/output.adb
View File

@ -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;
---------------

1
gcc/ada/s-rident.ads
View File

@ -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))

4
gcc/ada/sem_ch13.adb
View File

@ -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;

9
gcc/ada/sem_ch13.ads
View File

@ -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

11
gcc/ada/sem_ch3.adb
View File

@ -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;

22
gcc/ada/sem_res.adb
View File

@ -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).