Skip to content

R
riscv-gcc-1
Commit e1f3cb58 by Arnaud Charlet
Options

[multiple changes] 

2009-06-24  Robert Dewar  <dewar@adacore.com>

	* prj-nmsc.adb, prj-nmsc.ads, prj-proc.adb, prj.adb: Minor reformatting

	* a-strsea.adb (Count): Avoid local copy on stack, speed up unmapped
	case.
	(Index): Ditto.

2009-06-24  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Analyze_One_Call): Check that at least one actual is
	present when checking whether a call may be interpreted as an indexing
	of the result of a call.

	* exp_ch9.adb (Expand_N_Subprogram_Declaration): Place the generated
	body for a null procedure on the freeze actions for the procedure, so
	that it will be analyzed at the proper place without premature freezing
	of actuals.

	* sem_ch3.adb (Check_Completion): Code cleanup. 
	Do not diagnose a null procedure without a body, if previous errors
	have disabled expansion.

2009-06-24  Doug Rupp  <rupp@adacore.com>

	* init.c [VMS] Resignal C$_SIGKILL

2009-06-24  Ed Falis  <falis@adacore.com>

	* s-vxwext.adb, s-vxwext-kernel.adb: Add s-vxwext body for VxWorks 5
	Define ERROR in body for VxWorks 6 kernel

2009-06-24  Pascal Obry  <obry@adacore.com>

	* g-socket.adb, g-socket.ads: Fix possible unexpected constraint error
	in [Send/Receive]_Socket.

From-SVN: r148905
parent c9287857
Showing with 414 additions and 173 deletions
gcc/ada/ChangeLog
2009-06-24 Robert Dewar <dewar@adacore.com>
* prj-nmsc.adb, prj-nmsc.ads, prj-proc.adb, prj.adb: Minor reformatting
* a-strsea.adb (Count): Avoid local copy on stack, speed up unmapped
case.
(Index): Ditto.
2009-06-24 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Analyze_One_Call): Check that at least one actual is
present when checking whether a call may be interpreted as an indexing
of the result of a call.
* exp_ch9.adb (Expand_N_Subprogram_Declaration): Place the generated
body for a null procedure on the freeze actions for the procedure, so
that it will be analyzed at the proper place without premature freezing
of actuals.
* sem_ch3.adb (Check_Completion): Code cleanup.
Do not diagnose a null procedure without a body, if previous errors
have disabled expansion.
2009-06-24 Doug Rupp <rupp@adacore.com>
* init.c [VMS] Resignal C$_SIGKILL
2009-06-24 Ed Falis <falis@adacore.com>
* s-vxwext.adb, s-vxwext-kernel.adb: Add s-vxwext body for VxWorks 5
Define ERROR in body for VxWorks 6 kernel
2009-06-24 Pascal Obry <obry@adacore.com>
* g-socket.adb, g-socket.ads: Fix possible unexpected constraint error
in [Send/Receive]_Socket.
2009-06-24 Emmanuel Briot <briot@adacore.com>
* prj-proc.adb, prj-proc.ads, prj.ads, prj-nmsc.adb, prj-nmsc.ads,
......
gcc/ada/exp_ch6.adb
......@@ -4440,35 +4440,24 @@ package body Exp_Ch6 is
Pop_Scope;
end if;
-- Ada 2005 (AI-348): Generation of the null body
-- Ada 2005 (AI-348): Generate body for a null procedure.
-- In most cases this is superfluous because calls to it
-- will be automatically inlined, but we definitely need
-- the body if preconditions for the procedure are present.
elsif Nkind (Specification (N)) = N_Procedure_Specification
and then Null_Present (Specification (N))
then
declare
Bod : constant Node_Id :=
Make_Subprogram_Body (Loc,
Specification =>
New_Copy_Tree (Specification (N)),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Make_Null_Statement (Loc))));
Bod : constant Node_Id := Body_To_Inline (N);
begin
Set_Body_To_Inline (N, Bod);
Insert_After (N, Bod);
Analyze (Bod);
Set_Has_Completion (Subp, False);
Append_Freeze_Action (Subp, Bod);
-- Corresponding_Spec isn't being set by Analyze_Subprogram_Body,
-- evidently because Set_Has_Completion is called earlier for null
-- procedures in Analyze_Subprogram_Declaration, so we force its
-- setting here. If the setting of Has_Completion is not set
-- earlier, then it can result in missing body errors if other
-- errors were already reported (since expansion is turned off).
-- The body now contains raise statements, so calls to it will
-- not be inlined.
-- Should creation of the empty body be moved to the analyzer???
Set_Corresponding_Spec (Bod, Defining_Entity (Specification (N)));
Set_Is_Inlined (Subp, False);
end;
end if;
end Expand_N_Subprogram_Declaration;
......@@ -4910,8 +4899,8 @@ package body Exp_Ch6 is
-- Check if this is a declared null procedure
elsif Nkind (Decl) = N_Subprogram_Declaration then
if Null_Present (Specification (Decl)) then
return True;
if not Null_Present (Specification (Decl)) then
return False;
elsif No (Body_To_Inline (Decl)) then
return False;
......@@ -4936,8 +4925,9 @@ package body Exp_Ch6 is
Stat2 := Next (Stat);
return
Nkind (Stat) = N_Null_Statement
and then
Is_Empty_List (Declarations (Orig_Bod))
and then Nkind (Stat) = N_Null_Statement
and then
(No (Stat2)
or else
(Nkind (Stat2) = N_Simple_Return_Statement
......
gcc/ada/g-socket.adb
......@@ -1617,7 +1617,15 @@ package body GNAT.Sockets is
Raise_Socket_Error (Socket_Errno);
end if;
Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
if Res = 0
and then Item'First = Ada.Streams.Stream_Element_Offset'First
then
-- No data sent and first index is first Stream_Element_Offset'First
-- Last is set to Stream_Element_Offset'Last.
Last := Ada.Streams.Stream_Element_Offset'Last;
else
Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
end if;
end Receive_Socket;
--------------------
......@@ -1889,7 +1897,15 @@ package body GNAT.Sockets is
Raise_Socket_Error (Socket_Errno);
end if;
Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
if Res = 0
and then Item'First = Ada.Streams.Stream_Element_Offset'First
then
-- No data sent and first index is first Stream_Element_Offset'First
-- Last is set to Stream_Element_Offset'Last.
Last := Ada.Streams.Stream_Element_Offset'Last;
else
Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
end if;
end Send_Socket;
-----------------
......
gcc/ada/g-socket.ads
......@@ -895,9 +895,10 @@ package GNAT.Sockets is
Flags : Request_Flag_Type := No_Request_Flag);
-- Receive message from Socket. Last is the index value such that Item
-- (Last) is the last character assigned. Note that Last is set to
-- Item'First - 1 when the socket has been closed by peer. This is not an
-- error and no exception is raised. Flags allows to control the
-- reception. Raise Socket_Error on error.
-- Item'First - 1 (or to Stream_Element_Array'Last if Item'First is
-- Stream_Element_Offset'First) when the socket has been closed by peer.
-- This is not an error and no exception is raised. Flags allows to
-- control the reception. Raise Socket_Error on error.
procedure Receive_Socket
(Socket : Socket_Type;
......@@ -933,11 +934,16 @@ package GNAT.Sockets is
To : access Sock_Addr_Type;
Flags : Request_Flag_Type := No_Request_Flag);
pragma Inline (Send_Socket);
-- Transmit a message over a socket. For a datagram socket, the address is
-- given by To.all. For a stream socket, To must be null. Flags
-- allows to control the transmission. Raises Socket_Error on error.
-- Note: this subprogram is inlined because it is also used to implement
-- the two variants below.
-- Transmit a message over a socket. For a datagram socket, the address
-- is given by To.all. For a stream socket, To must be null. Last is
-- the index value such that Item (Last) is the last character
-- sent. Note that Last is set to Item'First - 1 (or to
-- Stream_Element_Array'Last if Item'First is
-- Stream_Element_Offset'First) when the socket has been closed by
-- peer. This is not an error and no exception is raised. Flags allows
-- to control the transmission. Raises Socket_Error on error. Note:
-- this subprogram is inlined because it is also used to implement the
-- two variants below.
procedure Send_Socket
(Socket : Socket_Type;
......
gcc/ada/init.c
......@@ -1136,6 +1136,7 @@ extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */
#define SS$_RESIGNAL 2328
/* These codes are in standard message libraries. */
extern int C$_SIGKILL;
extern int CMA$_EXIT_THREAD;
extern int SS$_DEBUG;
extern int SS$_INTDIV;
......@@ -1312,6 +1313,7 @@ typedef int
resignal_predicate (int code);
const int *cond_resignal_table [] = {
&C$_SIGKILL,
&CMA$_EXIT_THREAD,
&SS$_DEBUG,
&LIB$_KEYNOTFOU,
......
gcc/ada/prj-nmsc.ads
......@@ -41,13 +41,13 @@ private package Prj.Nmsc is
-- Free the memory occupied by Proc_Data
procedure Check
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Report_Error : Put_Line_Access;
When_No_Sources : Error_Warning;
Current_Dir : String;
Proc_Data : in out Processing_Data;
Is_Config_File : Boolean;
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
Report_Error : Put_Line_Access;
When_No_Sources : Error_Warning;
Current_Dir : String;
Proc_Data : in out Processing_Data;
Is_Config_File : Boolean;
Compiler_Driver_Mandatory : Boolean;
Allow_Duplicate_Basenames : Boolean);
-- Perform consistency and semantic checks on a project, starting from the
......@@ -75,6 +75,7 @@ private package Prj.Nmsc is
-- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute
-- for each language must be defined, or we will not look for its source
-- files.
--
-- If Allow_Duplicate_Basenames, then files with the same base names are
-- authorized within a project for source-based languages (never for unit
-- based languages)
......
gcc/ada/prj-proc.adb
......@@ -285,11 +285,11 @@ package body Prj.Proc is
-----------
procedure Check
(In_Tree : Project_Tree_Ref;
Project : Project_Id;
Current_Dir : String;
When_No_Sources : Error_Warning;
Is_Config_File : Boolean;
(In_Tree : Project_Tree_Ref;
Project : Project_Id;
Current_Dir : String;
When_No_Sources : Error_Warning;
Is_Config_File : Boolean;
Compiler_Driver_Mandatory : Boolean;
Allow_Duplicate_Basenames : Boolean)
is
......@@ -1259,17 +1259,17 @@ package body Prj.Proc is
if not Is_Config_File then
Process_Project_Tree_Phase_2
(In_Tree => In_Tree,
Project => Project,
Success => Success,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Report_Error => Report_Error,
When_No_Sources => When_No_Sources,
Current_Dir => Current_Dir,
(In_Tree => In_Tree,
Project => Project,
Success => Success,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Report_Error => Report_Error,
When_No_Sources => When_No_Sources,
Current_Dir => Current_Dir,
Compiler_Driver_Mandatory => True,
Allow_Duplicate_Basenames => False,
Is_Config_File => Is_Config_File);
Is_Config_File => Is_Config_File);
end if;
end Process;
......
gcc/ada/prj.adb
......@@ -154,7 +154,7 @@ package body Prj is
procedure Language_Changed (Iter : in out Source_Iterator);
procedure Project_Changed (Iter : in out Source_Iterator);
-- Called when a new project or language was selected for this iterator.
-- Called when a new project or language was selected for this iterator
function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
-- Return True if there is at least one ALI file in the directory Dir
......@@ -845,15 +845,19 @@ package body Prj is
---------------
procedure Free_List (Source : in out Source_Id) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Source_Data, Source_Id);
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation (Source_Data, Source_Id);
Tmp : Source_Id;
begin
while Source /= No_Source loop
Tmp := Source.Next_In_Lang;
Free_List (Source.Alternate_Languages);
if Source.Unit /= null then
if Source.Unit /= null
and then Source.Kind in Spec_Or_Body
then
Source.Unit.File_Names (Source.Kind) := null;
end if;
......@@ -870,8 +874,9 @@ package body Prj is
(List : in out Project_List;
Free_Project : Boolean)
is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Project_List_Element, Project_List);
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
Tmp : Project_List;
begin
......@@ -892,9 +897,11 @@ package body Prj is
---------------
procedure Free_List (Languages : in out Language_Ptr) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Language_Data, Language_Ptr);
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
Tmp : Language_Ptr;
begin
while Languages /= null loop
Tmp := Languages.Next;
......@@ -909,16 +916,18 @@ package body Prj is
----------------
procedure Free_Units (Table : in out Units_Htable.Instance) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Unit_Data, Unit_Index);
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
Unit : Unit_Index;
begin
Unit := Units_Htable.Get_First (Table);
while Unit /= No_Unit_Index loop
if Unit.File_Names (Spec) /= null then
Unit.File_Names (Spec).Unit := No_Unit_Index;
end if;
if Unit.File_Names (Impl) /= null then
Unit.File_Names (Impl).Unit := No_Unit_Index;
end if;
......@@ -935,8 +944,8 @@ package body Prj is
----------
procedure Free (Tree : in out Project_Tree_Ref) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Project_Tree_Data, Project_Tree_Ref);
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref);
begin
if Tree /= null then
......@@ -1076,6 +1085,7 @@ package body Prj is
procedure Set_Mode (New_Mode : Mode) is
begin
Current_Mode := New_Mode;
case New_Mode is
when Ada_Only =>
Default_Language_Is_Ada := True;
......@@ -1462,10 +1472,12 @@ package body Prj is
----------------------------
function Get_Language_From_Name
(Project : Project_Id; Name : String) return Language_Ptr
(Project : Project_Id;
Name : String) return Language_Ptr
is
N : Name_Id;
N : Name_Id;
Result : Language_Ptr;
begin
Name_Len := Name'Length;
Name_Buffer (1 .. Name_Len) := Name;
......@@ -1484,6 +1496,26 @@ package body Prj is
return No_Language_Index;
end Get_Language_From_Name;
----------------
-- Other_Part --
----------------
function Other_Part (Source : Source_Id) return Source_Id is
begin
if Source.Unit /= No_Unit_Index then
case Source.Kind is
when Impl =>
return Source.Unit.File_Names (Spec);
when Spec =>
return Source.Unit.File_Names (Impl);
when Sep =>
return No_Source;
end case;
else
return No_Source;
end if;
end Other_Part;
begin
-- Make sure that the standard config and user project file extensions are
-- compatible with canonical case file naming.
......
gcc/ada/s-vxwext-kernel.adb
......@@ -34,6 +34,8 @@
package body System.VxWorks.Ext is
ERROR : constant := -1;
--------------
-- Int_Lock --
--------------
......
gcc/ada/s-vxwext.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . V X W O R K S . E X T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNARL 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNARL; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
------------------------------------------------------------------------------
-- This package provides vxworks specific support functions needed
-- by System.OS_Interface.
-- This is the VxWorks 5.x version of this package
package body System.VxWorks.Ext is
ERROR : constant := -1;
------------------------
-- taskCpuAffinitySet --
------------------------
function taskCpuAffinitySet (tid : t_id; CPU : int) return int is
pragma Unreferenced (tid, CPU);
begin
return ERROR;
end taskCpuAffinitySet;
end System.VxWorks.Ext;
gcc/ada/sem_ch3.adb
......@@ -8609,23 +8609,39 @@ package body Sem_Ch3 is
-- source (including the _Call primitive operation of RAS types,
-- which has to have the flag Comes_From_Source for other purposes):
-- we assume that the expander will provide the missing completion.
-- In case of previous errors, other expansion actions that provide
-- bodies for null procedures with not be invoked. so inhibit message
-- in those cases.
elsif Ekind (E) = E_Function
or else Ekind (E) = E_Procedure
or else Ekind (E) = E_Generic_Function
or else Ekind (E) = E_Generic_Procedure
then
if not Has_Completion (E)
and then not (Is_Subprogram (E)
and then Is_Abstract_Subprogram (E))
and then not (Is_Subprogram (E)
and then
(not Comes_From_Source (E)
or else Chars (E) = Name_uCall))
and then Nkind (Parent (Unit_Declaration_Node (E))) /=
N_Compilation_Unit
and then Chars (E) /= Name_uSize
if Has_Completion (E) then
null;
elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then
null;
elsif Is_Subprogram (E)
and then (not Comes_From_Source (E)
or else Chars (E) = Name_uCall)
then
null;
elsif
Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
then
null;
elsif Nkind (Parent (E)) = N_Procedure_Specification
and then Null_Present (Parent (E))
and then Serious_Errors_Detected > 0
then
null;
else
Post_Error;
end if;
......
gcc/ada/sem_ch4.adb
......@@ -2262,7 +2262,9 @@ package body Sem_Ch4 is
return;
end if;
if Present (Actuals)
-- An indexing requires at least one actual.
if not Is_Empty_List (Actuals)
and then
(Needs_No_Actuals (Nam)
or else
......
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