* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@164972
138bc75d-0d04-0410-961f-
82ee72b054a4
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.
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 --
-- 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;
-- (.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,
-- --
-- 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- --
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
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
-- --
-- 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- --
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 --
--------------------------------
-- 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
---------------------
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;
----------------
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");
-- --
-- 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- --
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;
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);
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 --
------------------------
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);
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");
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;
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)))
(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))
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)
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;
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
projects / platform / upstream / linaro-gcc.git / commitdiff