diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 31 | ||||
| -rw-r--r-- | gcc/ada/clean.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/errout.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/prj-nmsc.adb | 94 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 42 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 44 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 10 |
9 files changed, 223 insertions, 31 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index eab6c1ceab4..532d8dc982e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2009-11-30 Emmanuel Briot <briot@adacore.com> + + * clean.adb ("-eL"): Also set Follow_Links_For_Dirs, to match what is + done in other project-aware tools like gnatmake and gprbuild. + +2009-11-30 Jerome Lambourg <lambourg@adacore.com> + + * exp_ch3.adb (Make_Predefined_Primitive_Specs): Take care of CIL + ValueTypes. + * exp_ch7.adb (Needs_Finalization): Do not finalize CIL valuetypes. + * sem_util.adb (Is_Value_Type): Protect against invalid calls to Chars + (Is_Delegate): New method used for CIL. + * sem_util.ads (Is_Delegate): New method for CIL handling. + (Is_Value_Type): Improve documentation. + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * errout.adb (Unwind_Internal_Type): Improve error reporting if the + type is an anonymous access to subprogram that is the type of a formal + in a subprogram spec. + +2009-11-30 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_Interfaces): In a Stand-Alone Library project, if + attribute Interfaces is not declared, then Library_Interface should + define the interfaces. + +2009-11-30 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb: New semantics for Annotate. + 2009-11-30 Tristan Gingold <gingold@adacore.com> * gcc-interface/Makefile.in: Do not link with -static-libgcc on Darwin. diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index b7bfd059869..978a5e7006f 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -1740,6 +1740,7 @@ package body Clean is when 'e' => if Arg = "-eL" then Follow_Links_For_Files := True; + Follow_Links_For_Dirs := True; else Bad_Argument; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index aa36a9ddaab..3ab53262579 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2848,7 +2848,30 @@ package body Errout is Buffer_Remove ("type "); end if; - Set_Msg_Str ("access to subprogram with profile "); + if Is_Itype (Ent) then + declare + Assoc : constant Node_Id := + Associated_Node_For_Itype (Ent); + + begin + if Nkind (Assoc) = N_Procedure_Specification + or else Nkind (Assoc) = N_Function_Specification + then + + -- Anonymous access to subprogram in a signature + -- Indicate the enclosing subprogram. + + Ent := + Defining_Unit_Name + (Associated_Node_For_Itype (Ent)); + Set_Msg_Str + ("access to subprogram declared in profile of "); + + else + Set_Msg_Str ("access to subprogram with profile "); + end if; + end; + end if; elsif Ekind (Ent) = E_Function then Set_Msg_Str ("access to function "); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 9a91e2aa9bb..f32f0e28846 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8121,7 +8121,9 @@ package body Exp_Ch3 is and then not Is_Limited_Interface (Tag_Typ) and then Is_Limited_Interface (Etype (Tag_Typ))) then - if not Is_Limited_Type (Tag_Typ) then + if not Is_Limited_Type (Tag_Typ) + and then not Is_Value_Type (Tag_Typ) + then Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index a4f6a66fd9b..980acf697c2 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3294,7 +3294,8 @@ package body Exp_Ch7 is return (Is_Class_Wide_Type (T) and then not In_Finalization_Root (T) - and then not Restriction_Active (No_Finalization)) + and then not Restriction_Active (No_Finalization) + and then not Is_Value_Type (Etype (T))) or else Is_Controlled (T) or else Has_Some_Controlled_Component (T) or else (Is_Concurrent_Type (T) diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 1f7c5e49333..9b65dc3a16c 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -2520,6 +2520,12 @@ package body Prj.Nmsc is Project.Decl.Attributes, Data.Tree); + Library_Interface : constant Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Interface, + Project.Decl.Attributes, + Data.Tree); + List : String_List_Id; Element : String_Element; Name : File_Name_Type; @@ -2604,22 +2610,90 @@ package body Prj.Nmsc is Project.Interfaces_Defined := True; - elsif Project.Extends /= No_Project then - Project.Interfaces_Defined := Project.Extends.Interfaces_Defined; + elsif Project.Library and then not Library_Interface.Default then - if Project.Interfaces_Defined then - Iter := For_Each_Source (Data.Tree, Project); + -- Set In_Interfaces to False for all sources. It will be set to True + -- later for the sources in the Library_Interface list. + + Project_2 := Project; + while Project_2 /= No_Project loop + Iter := For_Each_Source (Data.Tree, Project_2); loop Source := Prj.Element (Iter); exit when Source = No_Source; - - if not Source.Declared_In_Interfaces then - Source.In_Interfaces := False; - end if; - + Source.In_Interfaces := False; Next (Iter); end loop; - end if; + + Project_2 := Project_2.Extends; + end loop; + + List := Library_Interface.Values; + while List /= Nil_String loop + Element := Data.Tree.String_Elements.Table (List); + Get_Name_String (Element.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Name := Name_Find; + + Project_2 := Project; + Big_Loop_2 : + while Project_2 /= No_Project loop + Iter := For_Each_Source (Data.Tree, Project_2); + + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if Source.Unit /= No_Unit_Index and then + Source.Unit.Name = Name_Id (Name) + then + if not Source.Locally_Removed then + Source.In_Interfaces := True; + Source.Declared_In_Interfaces := True; + + Other := Other_Part (Source); + + if Other /= No_Source then + Other.In_Interfaces := True; + Other.Declared_In_Interfaces := True; + end if; + + if Current_Verbosity = High then + Write_Str (" interface: "); + Write_Line (Get_Name_String (Source.Path.Name)); + end if; + end if; + + exit Big_Loop_2; + end if; + + Next (Iter); + end loop; + + Project_2 := Project_2.Extends; + end loop Big_Loop_2; + + List := Element.Next; + end loop; + + Project.Interfaces_Defined := True; + + elsif Project.Extends /= No_Project and then + Project.Extends.Interfaces_Defined + then + Project.Interfaces_Defined := True; + + Iter := For_Each_Source (Data.Tree, Project); + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if not Source.Declared_In_Interfaces then + Source.In_Interfaces := False; + end if; + + Next (Iter); + end loop; end if; end Check_Interfaces; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 809665690de..9e9df3006fc 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5212,8 +5212,11 @@ package body Sem_Prag is -- Annotate -- -------------- - -- pragma Annotate (IDENTIFIER {, ARG}); + -- pragma Annotate (IDENTIFIER, [IDENTIFIER], {, ARG}); -- ARG ::= NAME | EXPRESSION + -- The first two arguments are by convention intended to refer + -- to an external tool and a tool-specific function. These + -- arguments are not analyzed. when Pragma_Annotate => Annotate : begin GNAT_Pragma; @@ -5225,26 +5228,33 @@ package body Sem_Prag is Exp : Node_Id; begin - Arg := Arg2; - while Present (Arg) loop - Exp := Expression (Arg); - Analyze (Exp); + if No (Arg2) then + Error_Pragma_Arg + ("pragma requires at least two arguments", Arg1); - if Is_Entity_Name (Exp) then - null; + else + Arg := Next (Arg2); + while Present (Arg) loop + Exp := Expression (Arg); + Analyze (Exp); - elsif Nkind (Exp) = N_String_Literal then - Resolve (Exp, Standard_String); + if Is_Entity_Name (Exp) then + null; - elsif Is_Overloaded (Exp) then - Error_Pragma_Arg ("ambiguous argument for pragma%", Exp); + elsif Nkind (Exp) = N_String_Literal then + Resolve (Exp, Standard_String); - else - Resolve (Exp); - end if; + elsif Is_Overloaded (Exp) then + Error_Pragma_Arg + ("ambiguous argument for pragma%", Exp); - Next (Arg); - end loop; + else + Resolve (Exp); + end if; + + Next (Arg); + end loop; + end if; end; end Annotate; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 48c7dff93b5..b01ab0aa55b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7040,11 +7040,55 @@ package body Sem_Util is function Is_Value_Type (T : Entity_Id) return Boolean is begin return VM_Target = CLI_Target + and then Nkind (T) in N_Has_Chars and then Chars (T) /= No_Name and then Get_Name_String (Chars (T)) = "valuetype"; end Is_Value_Type; ----------------- + -- Is_Delegate -- + ----------------- + + function Is_Delegate (T : Entity_Id) return Boolean is + Desig_Type : Entity_Id; + begin + if VM_Target /= CLI_Target then + return False; + end if; + + -- Access-to-subprograms are delegates in CIL + if Ekind (T) = E_Access_Subprogram_Type then + return True; + end if; + + if Ekind (T) not in Access_Kind then + -- a delegate is a managed pointer. If no designated type is defined + -- it means that it's not a delegate. + return False; + end if; + + Desig_Type := Etype (Directly_Designated_Type (T)); + + if not Is_Tagged_Type (Desig_Type) then + return False; + end if; + + -- Test if the type is inherited from [mscorlib]System.Delegate + while Etype (Desig_Type) /= Desig_Type loop + if Chars (Scope (Desig_Type)) /= No_Name + and then Is_Imported (Scope (Desig_Type)) + and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" + then + return True; + end if; + + Desig_Type := Etype (Desig_Type); + end loop; + + return False; + end Is_Delegate; + + ----------------- -- Is_Variable -- ----------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 016ff91f52f..c1d534a3fc8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -800,8 +800,14 @@ package Sem_Util is function Is_Value_Type (T : Entity_Id) return Boolean; -- Returns true if type T represents a value type. This is only relevant to -- CIL, will always return false for other targets. - -- What is a "value type", since this is not an Ada term, it should be - -- defined here ??? + -- A value type is a CIL object that is accessed directly, as opposed to + -- the other CIL objects that are accessed through managed pointers. + + function Is_Delegate (T : Entity_Id) return Boolean; + -- Returns true if type T represents a delegate. A Delegate is the CIL + -- object used to represent access-to-subprogram types. + -- This is only relevant to CIL, will always return false for other + -- targets. function Is_Variable (N : Node_Id) return Boolean; -- Determines if the tree referenced by N represents a variable, i.e. |
