summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/ada/ChangeLog30
-rw-r--r--gcc/ada/prj-env.adb23
-rw-r--r--gcc/ada/prj-env.ads9
-rw-r--r--gcc/ada/s-asthan-vms-alpha.adb26
-rw-r--r--gcc/ada/s-osinte-vxworks.adb11
-rw-r--r--gcc/ada/s-osinte-vxworks.ads5
-rw-r--r--gcc/ada/s-taprop-vxworks.adb6
-rw-r--r--gcc/ada/s-vxwext-kernel.ads3
-rw-r--r--gcc/ada/s-vxwext-rtp.adb39
-rw-r--r--gcc/ada/s-vxwext-rtp.ads3
-rw-r--r--gcc/ada/s-vxwext.ads3
-rw-r--r--gcc/ada/sem_ch3.adb36
-rw-r--r--gcc/ada/sem_ch6.adb1
-rw-r--r--gcc/ada/sem_disp.adb22
-rw-r--r--gcc/ada/sem_disp.ads10
15 files changed, 144 insertions, 83 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 13f3fbe2202..4e318038511 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,35 @@
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
a "**" pattern properly exists, and report an error otherwise.
diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb
index cb01145d24a..a9e9a8339d3 100644
--- a/gcc/ada/prj-env.adb
+++ b/gcc/ada/prj-env.adb
@@ -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 --
diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads
index d4e3eb5ca42..17d5e48c577 100644
--- a/gcc/ada/prj-env.ads
+++ b/gcc/ada/prj-env.ads
@@ -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,
diff --git a/gcc/ada/s-asthan-vms-alpha.adb b/gcc/ada/s-asthan-vms-alpha.adb
index 2e04081f410..623538f8613 100644
--- a/gcc/ada/s-asthan-vms-alpha.adb
+++ b/gcc/ada/s-asthan-vms-alpha.adb
@@ -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
diff --git a/gcc/ada/s-osinte-vxworks.adb b/gcc/ada/s-osinte-vxworks.adb
index c53cce259f7..c3b2814474a 100644
--- a/gcc/ada/s-osinte-vxworks.adb
+++ b/gcc/ada/s-osinte-vxworks.adb
@@ -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 --
--------------------------------
diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads
index dd5f1eb1d6c..857b7cd1c04 100644
--- a/gcc/ada/s-osinte-vxworks.ads
+++ b/gcc/ada/s-osinte-vxworks.ads
@@ -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
diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb
index d5726ec66c6..45686ea0423 100644
--- a/gcc/ada/s-taprop-vxworks.adb
+++ b/gcc/ada/s-taprop-vxworks.adb
@@ -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;
----------------
diff --git a/gcc/ada/s-vxwext-kernel.ads b/gcc/ada/s-vxwext-kernel.ads
index 0df9211a68f..59dfee03ac7 100644
--- a/gcc/ada/s-vxwext-kernel.ads
+++ b/gcc/ada/s-vxwext-kernel.ads
@@ -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");
diff --git a/gcc/ada/s-vxwext-rtp.adb b/gcc/ada/s-vxwext-rtp.adb
index b11dde27d32..39b7acf4c13 100644
--- a/gcc/ada/s-vxwext-rtp.adb
+++ b/gcc/ada/s-vxwext-rtp.adb
@@ -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 --
------------------------
diff --git a/gcc/ada/s-vxwext-rtp.ads b/gcc/ada/s-vxwext-rtp.ads
index 844d39415db..7cfd48ce340 100644
--- a/gcc/ada/s-vxwext-rtp.ads
+++ b/gcc/ada/s-vxwext-rtp.ads
@@ -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);
diff --git a/gcc/ada/s-vxwext.ads b/gcc/ada/s-vxwext.ads
index 1559d7d8e14..f39ccbf3f63 100644
--- a/gcc/ada/s-vxwext.ads
+++ b/gcc/ada/s-vxwext.ads
@@ -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");
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 9662357e807..4562bfe8d98 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -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;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 80b3eb19776..6994b40aeb3 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -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)))
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index f40df26b59a..0cec5546faa 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -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;
diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads
index 1888a6854ab..428531d0338 100644
--- a/gcc/ada/sem_disp.ads
+++ b/gcc/ada/sem_disp.ads
@@ -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
View Lorry Controller Status