diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 13 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 238 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/prj.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/s-rident.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 26 |
7 files changed, 273 insertions, 40 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 38b62351cf3..0e30e766c26 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2012-07-12 Robert Dewar <dewar@adacore.com> + + * make.adb, sem_ch9.adb, prj.adb, s-rident.ads, snames.ads-tmpl: Minor + reformatting. + +2012-07-12 Javier Miranda <miranda@adacore.com> + + * exp_ch3.adb (Is_User_Defined_Equality): New subprogram. + (Make_Neq_Body): New subprogram. + (Make_Predefined_Primitive_Specs): Adding local variable + Has_Predef_Eq_ Renaming to ensure that we enable the machinery + which handles renamings of predefined primitive operators. + 2012-07-09 Pascal Obry <obry@adacore.com> * prj.adb (For_Every_Project_Imported_Context): Make sure we diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 7f7aa6f6bb7..369d895906b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -202,6 +202,9 @@ package body Exp_Ch3 is -- Check if E is defined in the RTL (in a child of Ada or System). Used -- to avoid to bring in the overhead of _Input, _Output for tagged types. + function Is_User_Defined_Equality (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a user defined equality function + function Is_Variable_Size_Array (E : Entity_Id) return Boolean; -- Returns true if E has variable size components @@ -237,6 +240,11 @@ package body Exp_Ch3 is -- formals at some upper level). E provides the Sloc to be used for the -- generated code. + function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id; + -- Search for a renaming of the inequality dispatching primitive of + -- this tagged type. If found then build and return the corresponding + -- rename-as-body inequality subprogram; otherwise return Empty. + procedure Make_Predefined_Primitive_Specs (Tag_Typ : Entity_Id; Predef_List : out List_Id; @@ -7677,6 +7685,18 @@ package body Exp_Ch3 is end loop; end Init_Secondary_Tags; + ------------------------ + -- Is_User_Defined_Eq -- + ------------------------ + + function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is + begin + return Chars (Prim) = Name_Op_Eq + and then Etype (First_Formal (Prim)) = + Etype (Next_Formal (First_Formal (Prim))) + and then Base_Type (Etype (Prim)) = Standard_Boolean; + end Is_User_Defined_Equality; + ---------------------------- -- Is_Variable_Size_Array -- ---------------------------- @@ -8140,6 +8160,175 @@ package body Exp_Ch3 is end if; end Make_Eq_If; + -------------------- + -- Make_Neq_Body -- + -------------------- + + function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is + + function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean; + -- Returns true if Prim is a renaming of an unresolved predefined + -- inequality operation. + + -------------------------------- + -- Is_Predefined_Neq_Renaming -- + -------------------------------- + + function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is + begin + return Chars (Prim) /= Name_Op_Ne + and then Present (Alias (Prim)) + and then Comes_From_Source (Prim) + and then Is_Intrinsic_Subprogram (Alias (Prim)) + and then Chars (Alias (Prim)) = Name_Op_Ne; + end Is_Predefined_Neq_Renaming; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ)); + Stmts : constant List_Id := New_List; + Decl : Node_Id; + Eq_Prim : Entity_Id; + Left_Op : Entity_Id; + Renaming_Prim : Entity_Id; + Right_Op : Entity_Id; + Target : Entity_Id; + + -- Start of processing for Make_Neq_Body + + begin + -- For a call on a renaming of a dispatching subprogram that is + -- overridden, if the overriding occurred before the renaming, then + -- the body executed is that of the overriding declaration, even if the + -- overriding declaration is not visible at the place of the renaming; + -- otherwise, the inherited or predefined subprogram is called, see + -- (RM 8.5.4(8)) + + -- Stage 1: Search for a renaming of the unequality primitive and also + -- search for an overriding of the equality primitive located before the + -- renaming declaration. + + declare + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + Eq_Prim := Empty; + Renaming_Prim := Empty; + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Is_User_Defined_Equality (Prim) + and then No (Alias (Prim)) + then + if No (Renaming_Prim) then + pragma Assert (No (Eq_Prim)); + Eq_Prim := Prim; + end if; + + elsif Is_Predefined_Neq_Renaming (Prim) then + Renaming_Prim := Prim; + end if; + + Next_Elmt (Elmt); + end loop; + end; + + -- No further action needed if no renaming was found + + if No (Renaming_Prim) then + return Empty; + end if; + + -- Stage 2: Replace the renaming declaration by a subprogram declaration + -- (required to add its body) + + Decl := Parent (Parent (Renaming_Prim)); + Rewrite (Decl, + Make_Subprogram_Declaration (Loc, + Specification => Specification (Decl))); + Set_Analyzed (Decl); + + -- Remove the decoration of intrinsic renaming subprogram + + Set_Is_Intrinsic_Subprogram (Renaming_Prim, False); + Set_Convention (Renaming_Prim, Convention_Ada); + Set_Alias (Renaming_Prim, Empty); + Set_Has_Completion (Renaming_Prim, False); + + -- Stage 3: Build the corresponding body + + Left_Op := First_Formal (Renaming_Prim); + Right_Op := Next_Formal (Left_Op); + + Decl := + Predef_Spec_Or_Body (Loc, + Tag_Typ => Tag_Typ, + Name => Chars (Renaming_Prim), + Profile => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Left_Op)), + Parameter_Type => New_Reference_To (Tag_Typ, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Right_Op)), + Parameter_Type => New_Reference_To (Tag_Typ, Loc))), + + Ret_Type => Standard_Boolean, + For_Body => True); + + -- If the overriding of the equality primitive occurred before the + -- renaming, then generate: + + -- function <Neq_Name> (X : Y : Typ) return Boolean is + -- begin + -- return not Oeq (X, Y); + -- end; + + if Present (Eq_Prim) then + Target := Eq_Prim; + + -- Otherwise build a nested subprogram which performs the predefined + -- evaluation of the equality operator. That is, generate: + + -- function <Neq_Name> (X : Y : Typ) return Boolean is + -- function Oeq (X : Y) return Boolean is + -- begin + -- <<body of default implementation>> + -- end; + -- begin + -- return not Oeq (X, Y); + -- end; + + else + declare + Local_Subp : Node_Id; + begin + Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq); + Set_Declarations (Decl, New_List (Local_Subp)); + Target := Defining_Entity (Local_Subp); + end; + end if; + + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Not (Loc, + Make_Function_Call (Loc, + Name => New_Reference_To (Target, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Chars (Left_Op)), + Make_Identifier (Loc, Chars (Right_Op))))))); + + Set_Handled_Statement_Sequence + (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts)); + return Decl; + end Make_Neq_Body; + ------------------------------- -- Make_Null_Procedure_Specs -- ------------------------------- @@ -8238,13 +8427,6 @@ package body Exp_Ch3 is Predef_List : out List_Id; Renamed_Eq : out Entity_Id) is - Loc : constant Source_Ptr := Sloc (Tag_Typ); - Res : constant List_Id := New_List; - Eq_Name : Name_Id := Name_Op_Eq; - Eq_Needed : Boolean; - Eq_Spec : Node_Id; - Prim : Elmt_Id; - function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; -- Returns true if Prim is a renaming of an unresolved predefined -- equality operation. @@ -8262,6 +8444,19 @@ package body Exp_Ch3 is and then Chars (Alias (Prim)) = Name_Op_Eq; end Is_Predefined_Eq_Renaming; + -- Local variables + + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Res : constant List_Id := New_List; + Eq_Name : Name_Id := Name_Op_Eq; + Eq_Needed : Boolean; + Eq_Spec : Node_Id; + Prim : Elmt_Id; + + Has_Predef_Eq_Renaming : Boolean := False; + -- Set to True if Tag_Typ has a primitive that renames the predefined + -- equality operator. Used to implement (RM 8-5-4(8)). + -- Start of processing for Make_Predefined_Primitive_Specs begin @@ -8299,9 +8494,9 @@ package body Exp_Ch3 is end loop; end; - -- Spec of "=" is expanded if the type is not limited and if a - -- user defined "=" was not already declared for the non-full - -- view of a private extension + -- Spec of "=" is expanded if the type is not limited and if a user + -- defined "=" was not already declared for the non-full view of a + -- private extension if not Is_Limited_Type (Tag_Typ) then Eq_Needed := True; @@ -8311,21 +8506,18 @@ package body Exp_Ch3 is -- If a primitive is encountered that renames the predefined -- equality operator before reaching any explicit equality -- primitive, then we still need to create a predefined equality - -- function, because calls to it can occur via the renaming. A new - -- name is created for the equality to avoid conflicting with any - -- user-defined equality. (Note that this doesn't account for + -- function, because calls to it can occur via the renaming. A + -- new name is created for the equality to avoid conflicting with + -- any user-defined equality. (Note that this doesn't account for -- renamings of equality nested within subpackages???) if Is_Predefined_Eq_Renaming (Node (Prim)) then + Has_Predef_Eq_Renaming := True; Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); -- User-defined equality - elsif Chars (Node (Prim)) = Name_Op_Eq - and then Etype (First_Formal (Node (Prim))) = - Etype (Next_Formal (First_Formal (Node (Prim)))) - and then Base_Type (Etype (Node (Prim))) = Standard_Boolean - then + elsif Is_User_Defined_Equality (Node (Prim)) then if No (Alias (Node (Prim))) or else Nkind (Unit_Declaration_Node (Node (Prim))) = N_Subprogram_Renaming_Declaration @@ -8394,7 +8586,7 @@ package body Exp_Ch3 is Ret_Type => Standard_Boolean); Append_To (Res, Eq_Spec); - if Eq_Name /= Name_Op_Eq then + if Has_Predef_Eq_Renaming then Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); Prim := First_Elmt (Primitive_Operations (Tag_Typ)); @@ -8966,6 +9158,14 @@ package body Exp_Ch3 is Append_To (Res, Decl); end if; + -- Body for inequality (if required!) + + Decl := Make_Neq_Body (Tag_Typ); + + if Present (Decl) then + Append_To (Res, Decl); + end if; + -- Body for dispatching assignment Decl := diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 91d64b51437..dca504d7919 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -4807,8 +4807,10 @@ package body Make is return; end if; - -- Regenerate libraries, if there are any and if object files - -- have been regenerated. + -- Regenerate libraries, if there are any and if object files have been + -- regenerated. Note that we skip this in CodePeer mode because we don't + -- need libraries in this case, and more importantly, the object files + -- may not be present. if Main_Project /= No_Project and then not CodePeer_Mode diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index d70315bbbbc..150d524d30f 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -599,12 +599,14 @@ package body Prj is function Has_Sources (P : Project_Id) return Boolean is Lang : Language_Ptr; + begin Lang := P.Languages; while Lang /= No_Language_Index loop if Lang.First_Source /= No_Source then return True; end if; + Lang := Lang.Next; end loop; @@ -617,6 +619,7 @@ package body Prj is function Get_From_Tree (P : Project_Id) return Project_Id is List : Project_List := Tree.Projects; + begin if not Has_Sources (P) then while List /= null loop @@ -625,6 +628,7 @@ package body Prj is then return List.Project; end if; + List := List.Next; end loop; end if; @@ -632,8 +636,12 @@ package body Prj is return P; end Get_From_Tree; + -- Local variables + List : Project_List; + -- Start of processing for Recursive_Check + begin if not Seen_Name.Contains (Project.Name) then diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index d067f3d7f4f..11943f074c3 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -30,16 +30,17 @@ ------------------------------------------------------------------------------ -- This package defines the set of restriction identifiers. It is a generic --- package that is instantiated by the compiler/binder in package Rident, and --- is instantiated in package System.Restrictions for use at run-time. +-- package that is instantiated by the binder for output of the restrictions +-- structure, and is instantiated in package System.Restrictions for use at +-- run-time. -- The reason that we make this a generic package is so that in the case of --- the instantiation in Rident for use at compile time and bind time, we can --- generate normal image tables for the enumeration types, which are needed --- for diagnostic and informational messages. At run-time we really do not --- want to waste the space for these image tables, and they are not needed, --- so we can do the instantiation under control of Discard_Names to remove --- the tables. +-- the instantiation in the binder, we can generate normal image tables for +-- the enumeration types, which are needed for diagnostic and informational +-- messages as well as for identification of restrictions. At run-time we +-- really do not want to waste the space for these image tables, and they are +-- not needed, so we can do the instantiation under control of Discard_Names +-- to remove the tables. pragma Compiler_Unit; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 6a9fedf253a..d6141bc1e05 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -244,6 +244,9 @@ package body Sem_Ch9 is ---------------- function Check_Node (N : Node_Id) return Traverse_Result is + + -- The following function belongs in sem_eval ??? + function Is_Static_Function (Attr : Node_Id) return Boolean; -- Given an attribute reference node Attr, return True if -- Attr denotes a static function according to the rules in diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index f4facab956b..27ee72e2c89 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -953,18 +953,24 @@ package Snames is Last_Attribute_Name : constant Name_Id := N + $; -- Names of internal attributes. They are not real attributes but special - -- names used internally by GNAT in order to deal with certain delayed - -- aspects (Aspect_CPU, Aspect_Dispatching_Domain, - -- Aspect_Interrupt_Priority) that don't have corresponding pragmas or - -- user-referencable attributes. It is convenient to have these internal - -- attributes available in processing the aspects, since the normal - -- approach is to convert an aspect into its corresponding pragma or - -- attribute specification. + -- names used internally by GNAT in order to deal with delayed aspects + -- (Aspect_CPU, Aspect_Dispatching_Domain, Aspect_Interrupt_Priority) that + -- don't have corresponding pragmas or user-referencable attributes. + + -- It is convenient to have these internal attributes available for + -- processing the aspects, since the normal approach is to convert an + -- aspect into its corresponding pragma or attribute specification. + + -- These attributes do have Attribute_Id values so that case statements + -- on Attribute_Id include these cases, but they are NOT included in the + -- Attribute_Name subtype defined above, which is typically used in the + -- front end for checking syntax of submitted programs (where the use of + -- internal attributes is not permitted). First_Internal_Attribute_Name : constant Name_Id := N + $; - Name_CPU : constant Name_Id := N + $; -- INT - Name_Dispatching_Domain : constant Name_Id := N + $; -- INT - Name_Interrupt_Priority : constant Name_Id := N + $; -- INT + Name_CPU : constant Name_Id := N + $; + Name_Dispatching_Domain : constant Name_Id := N + $; + Name_Interrupt_Priority : constant Name_Id := N + $; Last_Internal_Attribute_Name : constant Name_Id := N + $; -- Names of recognized locking policy identifiers |