[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

gcc/ada/ChangeLog

 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.
 

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 --

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,

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
 

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 --
    --------------------------------

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

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;
 
    ----------------

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");

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 --
    ------------------------

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);

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");

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;
 

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)))

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;
 

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