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!)
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.
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;
+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
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 --
--------------------
-- 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;
-- 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)));
with Ada.Streams; use Ada.Streams;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
with Interfaces.C.Strings;
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 --
---------
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
-- 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
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";
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;
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 --
-----------
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;
-- 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 =>
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.
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;
(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
-- --
-- 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- --
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;
---------------
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))
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;
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;
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
-- 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;
-- 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).
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 --
----------------------------
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
-- Start of processing for Resolve_Equality_Op
begin
+ Check_Direct_Boolean_Op (N);
+
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
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).
projects / gcc.git / commitdiff