diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6f2e874c65b..43e546c96ba 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,39 @@ +2011-08-03 Gary Dismukes + + * sem_ch6.adb (Find_Corresponding_Spec): When in an instance, skip + conforming subprogram renamings that appear to be completions if they + are not fully conformant. + Such renamings are homographs but not completions. + * sem_type.adb (Disambiguate): Handle disambiguation of overloaded + names in a subprogram renaming that appears in an instance. + +2011-08-03 Ed Schonberg + + * exp_util.adb (Expand_Subtype_From_Expr): if the type is limited but + not immutably limited, build actual subtype from expression to provide + proper bounds to caller. + +2011-08-03 Gary Dismukes + + * sem_ch8.adb: Minor comment correction. + +2011-08-03 Thomas Quinot + + * exp_strm.adb (Build_Array_Input_Function): In Ada 2005 mode, when + returning a limited array, use an extended return statement. + +2011-08-03 Vincent Celier + + * make.adb (Initialize): If --subdirs= is used, but no project file is + specified, attempt to create the specify subdir if it does not already + exist and use it as the object directory as if -D had been specified. + +2011-08-03 Arnaud Charlet + + * s-tpopsp-vms.adb: New file. + * s-taprop-vms.adb: Put back ATCB_Key, since needed by this file on VMS. + * gcc-interfaces/Makefile.in: Use s-taprop-vms.adb on VMS. + 2011-08-03 Emmanuel Briot * make.adb, makeutl.adb, makeutl.ads, clean.adb (Makeutl.Queue): new diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index f9b62941757..b89e088b2f6 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -149,7 +149,9 @@ package body Exp_Strm is Decls : List_Id; Ranges : List_Id; Stms : List_Id; + Rstmt : Node_Id; Indx : Node_Id; + Odecl : Node_Id; begin Decls := New_List; @@ -197,13 +199,13 @@ package body Exp_Strm is -- build a subtype indication with the proper bounds. if Is_Constrained (Stream_Base_Type (Typ)) then - Append_To (Decls, + Odecl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), Object_Definition => - New_Occurrence_Of (Stream_Base_Type (Typ), Loc))); + New_Occurrence_Of (Stream_Base_Type (Typ), Loc)); else - Append_To (Decls, + Odecl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), Object_Definition => @@ -212,19 +214,34 @@ package body Exp_Strm is New_Occurrence_Of (Stream_Base_Type (Typ), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => Ranges)))); + Constraints => Ranges))); end if; - Stms := New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - Make_Identifier (Loc, Name_S), - Make_Identifier (Loc, Name_V))), + Rstmt := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))); - Make_Simple_Return_Statement (Loc, - Expression => Make_Identifier (Loc, Name_V))); + if Ada_Version >= Ada_2005 then + Stms := New_List ( + Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Odecl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Rstmt)))); + else + -- pragma Assert (not Is_Limited_Type (Typ)); + -- Returning a local object, shouldn't happen in the case of a + -- limited type, but currently occurs in DSA stubs in Ada 95 mode??? + + Stms := New_List ( + Odecl, + Rstmt, + Make_Simple_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_V))); + end if; Fnam := Make_Defining_Identifier (Loc, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 1be16c1d2d5..7557a125a2a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1371,8 +1371,11 @@ package body Exp_Util is -- If the type is class-wide, the expression is dynamically tagged and -- we do not create an actual subtype either. Ditto for an interface. + -- For now this applies only if the type is immutably limited, and the + -- function being called is build-in-place. This will have to be revised + -- when build-in-place functions are generalized to other types. - elsif Is_Limited_Type (Exp_Typ) + elsif Is_Immutably_Limited_Type (Exp_Typ) and then (Is_Class_Wide_Type (Exp_Typ) or else Is_Interface (Exp_Typ) diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index fa153f6de92..386c05fb740 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1520,7 +1520,7 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) s-taprop.adb Main_Project, + -- In_Tree => Project_Tree, + -- Including_Libraries => True, + -- Include_Path => Use_Include_Path_File); -- If switch -C was specified, create a binder mapping file @@ -6729,6 +6734,38 @@ package body Make is Make_Failed ("-i and -D cannot be used simultaneously"); end if; + -- If --subdirs= is specified, but not -P, this is equivalent to -D, + -- except that the directory is created if it does not exist. + + if Prj.Subdirs /= null and then Project_File_Name = null then + if Object_Directory_Path /= null then + Make_Failed ("--subdirs and -D cannot be used simultaneously"); + + elsif In_Place_Mode then + Make_Failed ("--subdirs and -i cannot be used simultaneously"); + + else + if not Is_Directory (Prj.Subdirs.all) then + begin + Ada.Directories.Create_Path (Prj.Subdirs.all); + exception + when others => + Make_Failed ("unable to create object directory " & + Prj.Subdirs.all); + end; + end if; + + Object_Directory_Present := True; + + declare + Argv : constant String (1 .. Prj.Subdirs'Length) := + Prj.Subdirs.all; + begin + Scan_Make_Arg (Env, Argv, And_Save => False); + end; + end if; + end if; + -- Deal with -C= switch if Gnatmake_Mapping_File /= null then diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 5c1770bd8a3..bd19c474eaa 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -72,6 +72,9 @@ package body System.Task_Primitives.Operations is -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_Id associated with a thread + Environment_Task_Id : Task_Id; -- A variable to hold Task_Id for the environment task diff --git a/gcc/ada/s-tpopsp-vms.adb b/gcc/ada/s-tpopsp-vms.adb new file mode 100644 index 00000000000..42503f6cd99 --- /dev/null +++ b/gcc/ada/s-tpopsp-vms.adb @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2011, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a VMS version of this package where foreign threads are +-- recognized. + +separate (System.Task_Primitives.Operations) +package body Specific is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_Id) is + pragma Warnings (Off, Environment_Task); + Result : Interfaces.C.int; + + begin + Result := pthread_key_create (ATCB_Key'Access, null); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return pthread_getspecific (ATCB_Key) /= System.Null_Address; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_Id) is + Result : Interfaces.C.int; + begin + Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); + pragma Assert (Result = 0); + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have added some + -- functionality to Self. Suppose a C main program (with threads) calls an + -- Ada procedure and the Ada procedure calls the tasking runtime system. + -- Eventually, a call will be made to self. Since the call is not coming + -- from an Ada task, there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come from + -- recognized Ada tasks, and create an ATCB for the calling thread. + + -- The new ATCB will be "detached" from the normal Ada task master + -- hierarchy, much like the existing implicitly created signal-server + -- tasks. + + function Self return Task_Id is + Result : System.Address; + + begin + Result := pthread_getspecific (ATCB_Key); + + -- If the key value is Null then it is a non-Ada task + + if Result /= System.Null_Address then + return To_Task_Id (Result); + else + return Register_Foreign_Thread; + end if; + end Self; + +end Specific; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index ca7831e7ef6..6c69643cbdd 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6332,7 +6332,13 @@ package body Sem_Ch6 is if In_Instance then Set_Convention (Designator, Convention (E)); - if Nkind (N) = N_Subprogram_Body + -- Skip past subprogram bodies and subprogram renamings that + -- may appear to have a matching spec, but that aren't fully + -- conformant with it. That can occur in cases where an + -- actual type causes unrelated homographs in the instance. + + if Nkind_In (N, N_Subprogram_Body, + N_Subprogram_Renaming_Declaration) and then Present (Homonym (E)) and then not Fully_Conformant (Designator, E) then diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index d02e9118a97..19581b99ba1 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5461,7 +5461,7 @@ package body Sem_Ch8 is return Old_S; end Report_Overload; - -- Start of processing for Find_Renamed_Entry + -- Start of processing for Find_Renamed_Entity begin Old_S := Any_Id; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 7f43699d84e..e5b8b358760 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1751,15 +1751,26 @@ package body Sem_Type is -- case the resolution was to the explicit declaration in the -- generic, and remains so in the instance. + -- The same sort of disambiguation needed for calls is also required + -- for the name given in a subprogram renaming, and that case is + -- handled here as well. We test Comes_From_Source to exclude this + -- treatment for implicit renamings created for formal subprograms. + elsif In_Instance and then not In_Generic_Actual (N) then if Nkind (N) = N_Function_Call or else Nkind (N) = N_Procedure_Call_Statement + or else + (Nkind (N) in N_Has_Entity + and then + Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration + and then Comes_From_Source (Parent (N))) then declare Actual : Node_Id; Formal : Entity_Id; + Renam : Entity_Id := Empty; Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1); Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2); @@ -1781,14 +1792,32 @@ package body Sem_Type is return It1; end if; - Actual := First_Actual (N); + -- In the case of a renamed subprogram, pick up the entity + -- of the renaming declaration so we can traverse its + -- formal parameters. + + if Nkind (N) in N_Has_Entity then + Renam := Defining_Unit_Name (Specification (Parent (N))); + end if; + + if Present (Renam) then + Actual := First_Formal (Renam); + else + Actual := First_Actual (N); + end if; + Formal := First_Formal (Nam1); while Present (Actual) loop if Etype (Actual) /= Etype (Formal) then return It2; end if; - Next_Actual (Actual); + if Present (Renam) then + Next_Formal (Actual); + else + Next_Actual (Actual); + end if; + Next_Formal (Formal); end loop;