mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-25 20:06:11 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-10-05  Emmanuel Briot  <briot@adacore.com>

	* prj-env.adb, prj-env.ads (Set_Path): New subprogram.
	(Deep_Copy): Removed, not used.

2010-10-05  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Add_Internal_Interface_Entities): Code reorganization:
	move code that searches in the list of primitives of a tagged type for
	the entity that will be overridden by user-defined routines.
	* sem_disp.adb (Find_Primitive_Covering_Interface): Move here code
	previously located in routine Add_Internal_Interface_Entities.
	* sem_disp.ads (Find_Primitive_Covering_Interface): Update documentation
	* sem_ch6.adb (New_Overloaded_Entity): Add missing check on
	availability of attribute Alias.

2010-10-05  Ed Falis  <falis@adacore.com>

	* s-taprop-vxworks.adb, s-osinte-vxworks.adb, s-osinte-vxworks.ads,
	s-vxwext.ads, s-vxwext-kernel.ads, s-vxwext-rtp.adb, s-vxwext-rtp.ads:
	Move definition of intContext to System.OS_Interface.
	Add necessary variants in System.VxWorks.Extensions.

2010-10-05  Doug Rupp  <rupp@adacore.com>

	* s-asthan-vms-alpha.adb: On VMS, a task using
	pragma AST_Entry exhibits a memory leak when the task terminates
	because the vector allocated for the AST interface is not freed. Fixed
	by making the vector a controlled type.

From-SVN: r164972
This commit is contained in:
Arnaud Charlet 2010-10-05 11:37:44 +02:00
parent eada5fd1cf
commit 92817e8977
15 changed files with 144 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gcc/ada/ChangeLog
View File

@ -1,3 +1,33 @@
2010-10-05 Emmanuel Briot <briot@adacore.com>
* prj-env.adb, prj-env.ads (Set_Path): New subprogram.
(Deep_Copy): Removed, not used.
2010-10-05 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Add_Internal_Interface_Entities): Code reorganization:
move code that searches in the list of primitives of a tagged type for
the entity that will be overridden by user-defined routines.
* sem_disp.adb (Find_Primitive_Covering_Interface): Move here code
previously located in routine Add_Internal_Interface_Entities.
* sem_disp.ads (Find_Primitive_Covering_Interface): Update documentation
* sem_ch6.adb (New_Overloaded_Entity): Add missing check on
availability of attribute Alias.
2010-10-05 Ed Falis <falis@adacore.com>
* s-taprop-vxworks.adb, s-osinte-vxworks.adb, s-osinte-vxworks.ads,
s-vxwext.ads, s-vxwext-kernel.ads, s-vxwext-rtp.adb, s-vxwext-rtp.ads:
Move definition of intContext to System.OS_Interface.
Add necessary variants in System.VxWorks.Extensions.
2010-10-05 Doug Rupp <rupp@adacore.com>
* s-asthan-vms-alpha.adb: On VMS, a task using
pragma AST_Entry exhibits a memory leak when the task terminates
because the vector allocated for the AST interface is not freed. Fixed
by making the vector a controlled type.
2010-10-05 Emmanuel Briot <briot@adacore.com>
* prj-nmsc.adb (Expand_Subdirectory_Pattern): Check that the prefix in

23
gcc/ada/prj-env.adb
View File

@ -1974,22 +1974,17 @@ package body Prj.Env is
Path := Self.Path;
end Get_Path;
---------------
-- Deep_Copy --
---------------
--------------
-- Set_Path --
--------------
function Deep_Copy
(Self : Project_Search_Path) return Project_Search_Path is
procedure Set_Path
(Self : in out Project_Search_Path; Path : String) is
begin
if Self.Path = null then
return Project_Search_Path'
(Path => null, Cache => Projects_Paths.Nil);
else
return Project_Search_Path'
(Path => new String'(Self.Path.all),
Cache => Projects_Paths.Nil);
end if;
end Deep_Copy;
Free (Self.Path);
Self.Path := new String'(Path);
Projects_Paths.Reset (Self.Cache);
end Set_Path;
------------------
-- Find_Project --

9
gcc/ada/prj-env.ads
View File

@ -188,6 +188,11 @@ package Prj.Env is
-- been called, the value set by the last call to Set_Project_Path.
-- The returned value must not be modified.
procedure Set_Path
(Self : in out Project_Search_Path; Path : String);
-- Override the value of the project path.
-- This also removes the implicit default search directories
procedure Find_Project
(Self : in out Project_Search_Path;
Project_File_Name : String;
@ -202,10 +207,6 @@ package Prj.Env is
-- (.gpr) for the file name is optional.
-- Returns No_Name if no such project was found.
function Deep_Copy (Self : Project_Search_Path) return Project_Search_Path;
-- Return a deep copy of Self. The result can be modified independently of
-- Self, and must be freed by the caller
private
package Projects_Paths is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,

26
gcc/ada/s-asthan-vms-alpha.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1996-2010, 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- --
@ -48,14 +48,13 @@ with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Task_Primitives.Operations.DEC;
-- with Ada.Finalization;
-- removed, because of problem with controlled attribute ???
with Ada.Finalization;
with Ada.Task_Attributes;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
package body System.AST_Handling is
@ -190,15 +189,22 @@ package body System.AST_Handling is
type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data;
type AST_Handler_Vector_Ref is access all AST_Handler_Vector;
-- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
-- removed due to problem with controlled attribute, consequence is that
-- we have a memory leak if a task that has AST attribute entries is
-- terminated. ???
type AST_Vector_Ptr is record
type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
Vector : AST_Handler_Vector_Ref;
end record;
procedure Finalize (Obj : in out AST_Vector_Ptr);
-- Override Finalize so that the AST Vector gets freed.
procedure Finalize (Obj : in out AST_Vector_Ptr) is
procedure Free is new
Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref);
begin
if Obj.Vector /= null then
Free (Obj.Vector);
end if;
end Finalize;
AST_Vector_Init : AST_Vector_Ptr;
-- Initial value, treated as constant, Vector will be null

11
gcc/ada/s-osinte-vxworks.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1997-2010, 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- --
@ -229,6 +229,15 @@ package body System.OS_Interface is
Parameter);
end Interrupt_Connect;
-----------------------
-- Interrupt_Context --
-----------------------
function Interrupt_Context return int is
begin
return System.VxWorks.Ext.Interrupt_Context;
end Interrupt_Context;
--------------------------------
-- Interrupt_Number_To_Vector --
--------------------------------

5
gcc/ada/s-osinte-vxworks.ads
View File

@ -475,6 +475,11 @@ package System.OS_Interface is
-- handler which is invoked after the OS has saved enough context for a
-- high-level language routine to be safely invoked.
function Interrupt_Context return int;
pragma Inline (Interrupt_Context);
-- Return 1 if executing in an interrupt context; return 0 if executing in
-- a task context.
function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
pragma Inline (Interrupt_Number_To_Vector);
-- Convert a logical interrupt number to the hardware interrupt vector

6
gcc/ada/s-taprop-vxworks.adb
View File

@ -1336,12 +1336,8 @@ package body System.Task_Primitives.Operations is
---------------------
function Is_Task_Context return Boolean is
function intContext return int;
pragma Import (C, intContext, "intContext");
-- Binding to the C routine intContext. This function returns 1 only
-- if the current execution state is an interrupt context.
begin
return intContext /= 1;
return System.OS_Interface.Interrupt_Context /= 1;
end Is_Task_Context;
----------------

3
gcc/ada/s-vxwext-kernel.ads
View File

@ -61,6 +61,9 @@ package System.VxWorks.Ext is
Parameter : System.Address := System.Null_Address) return int;
pragma Import (C, Interrupt_Connect, "intConnect");
function Interrupt_Context return int;
pragma Import (C, Interrupt_Context, "intContext");
function Interrupt_Number_To_Vector
(intNum : int) return Interrupt_Vector;
pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec");

39
gcc/ada/s-vxwext-rtp.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2008-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2008-2010, 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- --
@ -53,15 +53,9 @@ package body System.VxWorks.Ext is
return ERROR;
end Int_Unlock;
--------------------
-- Set_Time_Slice --
--------------------
function Set_Time_Slice (ticks : int) return int is
pragma Unreferenced (ticks);
begin
return ERROR;
end Set_Time_Slice;
-----------------------
-- Interrupt_Connect --
-----------------------
function Interrupt_Connect
(Vector : Interrupt_Vector;
@ -72,6 +66,21 @@ package body System.VxWorks.Ext is
return ERROR;
end Interrupt_Connect;
-----------------------
-- Interrupt_Context --
-----------------------
function Interrupt_Context return int is
begin
-- For RTPs, never in an interrupt context
return 0;
end Interrupt_Context;
--------------------------------
-- Interrupt_Number_To_Vector --
--------------------------------
function Interrupt_Number_To_Vector
(intNum : int) return Interrupt_Vector is
pragma Unreferenced (intNum);
@ -79,6 +88,16 @@ package body System.VxWorks.Ext is
return 0;
end Interrupt_Number_To_Vector;
--------------------
-- Set_Time_Slice --
--------------------
function Set_Time_Slice (ticks : int) return int is
pragma Unreferenced (ticks);
begin
return ERROR;
end Set_Time_Slice;
------------------------
-- taskCpuAffinitySet --
------------------------

3
gcc/ada/s-vxwext-rtp.ads
View File

@ -61,6 +61,9 @@ package System.VxWorks.Ext is
Parameter : System.Address := System.Null_Address) return int;
pragma Convention (C, Interrupt_Connect);
function Interrupt_Context return int;
pragma Convention (C, Interrupt_Context);
function Interrupt_Number_To_Vector
(intNum : int) return Interrupt_Vector;
pragma Convention (C, Interrupt_Number_To_Vector);

3
gcc/ada/s-vxwext.ads
View File

@ -62,6 +62,9 @@ package System.VxWorks.Ext is
Parameter : System.Address := System.Null_Address) return int;
pragma Import (C, Interrupt_Connect, "intConnect");
function Interrupt_Context return int;
pragma Import (C, Interrupt_Context, "intContext");
function Interrupt_Number_To_Vector
(intNum : int) return Interrupt_Vector;
pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec");

36
gcc/ada/sem_ch3.adb
View File

@ -1567,41 +1567,9 @@ package body Sem_Ch3 is
if Is_Null_Interface_Primitive (Iface_Prim) then
goto Continue;
-- if the tagged type is defined at library level then we
-- invoke Check_Abstract_Overriding to report the error
-- and thus avoid generating the dispatch tables.
elsif Is_Library_Level_Tagged_Type (Tagged_Type) then
Check_Abstract_Overriding (Tagged_Type);
pragma Assert (Serious_Errors_Detected > 0);
return;
-- For tagged types defined in nested scopes it is still
-- possible to cover this interface primitive by means of
-- late overriding (see Override_Dispatching_Operation).
-- Search in the list of primitives of the type for the
-- entity that will be overridden in such case to reference
-- it in the internal entity that we build here. If the
-- primitive is not overridden then the error will be
-- reported later as part of the analysis of entities
-- defined in the enclosing scope.
else
declare
El : Elmt_Id;
begin
El := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (El)
and then Alias (Node (El)) /= Iface_Prim
loop
Next_Elmt (El);
end loop;
pragma Assert (Present (El));
Prim := Node (El);
end;
pragma Assert (False);
raise Program_Error;
end if;
end if;

1
gcc/ada/sem_ch6.adb
View File

@ -7625,6 +7625,7 @@ package body Sem_Ch6 is
if Ada_Version >= Ada_05
and then Present (Derived_Type)
and then Present (Alias (S))
and then Is_Dispatching_Operation (Alias (S))
and then Present (Find_Dispatching_Type (Alias (S)))
and then Is_Interface (Find_Dispatching_Type (Alias (S)))

22
gcc/ada/sem_disp.adb
View File

@ -1651,7 +1651,8 @@ package body Sem_Disp is
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id) return Entity_Id
is
E : Entity_Id;
E : Entity_Id;
El : Elmt_Id;
begin
pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
@ -1660,6 +1661,8 @@ package body Sem_Disp is
Is_Interface
(Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
-- Search in the homonym chain
E := Current_Entity (Iface_Prim);
while Present (E) loop
if Is_Subprogram (E)
@ -1672,6 +1675,23 @@ package body Sem_Disp is
E := Homonym (E);
end loop;
-- Search in the list of primitives of the type
El := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (El) loop
E := Node (El);
if No (Interface_Alias (E))
and then Alias (E) = Iface_Prim
then
return Node (El);
end if;
Next_Elmt (El);
end loop;
-- Not found
return Empty;
end Find_Primitive_Covering_Interface;

10
gcc/ada/sem_disp.ads
View File

@ -82,10 +82,12 @@ package Sem_Disp is
function Find_Primitive_Covering_Interface
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id) return Entity_Id;
-- Search in the homonym chain for the primitive of Tagged_Type that
-- covers Iface_Prim. The homonym chain traversal is required to catch
-- primitives associated with the partial view of private types when
-- processing the corresponding full view.
-- Search in the homonym chain for the primitive of Tagged_Type that covers
-- Iface_Prim. The homonym chain traversal is required to catch primitives
-- associated with the partial view of private types when processing the
-- corresponding full view. If the entity is not found then search for it
-- in the list of primitives of Tagged_Type. This latter search is needed
-- when the interface primitive is covered by a private subprogram.
function Is_Dynamically_Tagged (N : Node_Id) return Boolean;
-- Used to determine whether a call is dispatching, i.e. if is an