diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2010-10-05 11:37:44 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2010-10-05 11:37:44 +0200 |
commit | 92817e897757f430013104a01dbbaf222f7d950a (patch) | |
tree | 497f5b4a920a207a3da99a885ebca648bd450e5b | |
parent | eada5fd1cf4179586b126a4a6cf6a0e1f6e69a01 (diff) | |
download | gcc-92817e897757f430013104a01dbbaf222f7d950a.zip gcc-92817e897757f430013104a01dbbaf222f7d950a.tar.gz gcc-92817e897757f430013104a01dbbaf222f7d950a.tar.bz2 |
[multiple changes]
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
-rw-r--r-- | gcc/ada/ChangeLog | 30 | ||||
-rw-r--r-- | gcc/ada/prj-env.adb | 23 | ||||
-rw-r--r-- | gcc/ada/prj-env.ads | 9 | ||||
-rw-r--r-- | gcc/ada/s-asthan-vms-alpha.adb | 26 | ||||
-rw-r--r-- | gcc/ada/s-osinte-vxworks.adb | 11 | ||||
-rw-r--r-- | gcc/ada/s-osinte-vxworks.ads | 5 | ||||
-rw-r--r-- | gcc/ada/s-taprop-vxworks.adb | 6 | ||||
-rw-r--r-- | gcc/ada/s-vxwext-kernel.ads | 3 | ||||
-rw-r--r-- | gcc/ada/s-vxwext-rtp.adb | 39 | ||||
-rw-r--r-- | gcc/ada/s-vxwext-rtp.ads | 3 | ||||
-rw-r--r-- | gcc/ada/s-vxwext.ads | 3 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 36 | ||||
-rw-r--r-- | gcc/ada/sem_ch6.adb | 1 | ||||
-rw-r--r-- | gcc/ada/sem_disp.adb | 22 | ||||
-rw-r--r-- | gcc/ada/sem_disp.ads | 10 |
15 files changed, 144 insertions, 83 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 13f3fbe..4e31803 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 cb01145..a9e9a83 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 d4e3eb5..17d5e48 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 2e04081..623538f 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 c53cce2..c3b2814 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 dd5f1eb..857b7cd 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 d5726ec..45686ea 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 0df9211..59dfee0 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 b11dde2..39b7acf 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 844d394..7cfd48c 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 1559d7d..f39ccbf 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 9662357..4562bfe 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 80b3eb1..6994b40 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 f40df26..0cec554 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 1888a68..428531d 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 |