diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/ada/adaint.h | 7 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/makeutl.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/makeutl.ads | 50 | ||||
| -rw-r--r-- | gcc/ada/prj.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 75 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 5 |
8 files changed, 92 insertions, 87 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 036e813..febeecc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2009-07-28 Robert Dewar <dewar@adacore.com> + + * adaint.h, einfo.ads, prj.adb, sem_util.adb, makeutl.ads, + makeutl.adb: Minor reformatting & code reorganization + * sem_ch3.adb: Minor reformatting. + Fix spelling error (constraint for constrain) in error msg. + 2009-07-28 Emmanuel Briot <briot@adacore.com> * make.adb, makeutl.adb, makeutl.ads (Project_Tree): Duplicates the diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 471b5ab..79a1e4e 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -43,10 +43,9 @@ #define Encoding_8bits 1 /* Standard 8bits, CP_ACP on Windows. */ #define Encoding_Unspecified 2 /* Based on GNAT_CODE_PAGE env variable. */ -/* Large file support. It is unclear what portable mechanism we can - use to determine at compile time what support the system offers for - large files. For now we just list the platforms we have manually - tested. */ +/* Large file support. It is unclear what portable mechanism we can use to + determine at compile time what support the system offers for large files. + For now we just list the platforms we have manually tested. */ #if defined (__GLIBC__) || defined (sun) || defined (__sgi) #define GNAT_FOPEN fopen64 diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e2f1cbe..6330dec 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3192,7 +3192,7 @@ package Einfo is -- the case of an appearance of a simple variable that is not a renaming -- as the left side of an assignment in which case Referenced_As_LHS is -- set instead, or a similar appearance as an out parameter actual, in --- which case As_Out_Parameter_Parameter is set. +-- which case Referenced_As_Out_Parameter is set. -- Referenced_As_LHS (Flag36): -- Present in all entities. This flag is set instead of Referenced if a diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 4bac5a7..c0d9de4 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -162,12 +162,14 @@ package body Makeutl is function Check_Source_Info_In_ALI (The_ALI : ALI_Id) return Boolean is Unit_Name : Name_Id; + begin - U_Chk : - for U in ALIs.Table (The_ALI).First_Unit - .. ALIs.Table (The_ALI).Last_Unit + -- Loop through units + + for U in ALIs.Table (The_ALI).First_Unit .. + ALIs.Table (The_ALI).Last_Unit loop - -- Check if the file name is one of the source of the unit. + -- Check if the file name is one of the source of the unit Get_Name_String (Units.Table (U).Uname); Name_Len := Name_Len - 2; @@ -177,12 +179,12 @@ package body Makeutl is return False; end if; - -- Do the same check for each of the withed units + -- Loop to do same check for each of the withed units - W_Check : for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop declare WR : ALI.With_Record renames Withs.Table (W); + begin if WR.Sfile /= No_File then Get_Name_String (WR.Uname); @@ -194,21 +196,22 @@ package body Makeutl is end if; end if; end; - end loop W_Check; - end loop U_Chk; + end loop; + end loop; - -- Check also the subunits + -- Loop to check subunits - D_Check : - for D in ALIs.Table (The_ALI).First_Sdep - .. ALIs.Table (The_ALI).Last_Sdep + for D in ALIs.Table (The_ALI).First_Sdep .. + ALIs.Table (The_ALI).Last_Sdep loop declare SD : Sdep_Record renames Sdep.Table (D); + begin Unit_Name := SD.Subunit_Name; if Unit_Name /= No_Name then + -- For separates, the file is no longer associated with the -- unit ("proc-sep.adb" is not associated with unit "proc.sep". -- So we need to check whether the source file still exists in @@ -240,7 +243,7 @@ package body Makeutl is end if; end if; end; - end loop D_Check; + end loop; return True; end Check_Source_Info_In_ALI; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 09d8c2b..1dff5a1 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -36,8 +36,8 @@ package Makeutl is type Fail_Proc is access procedure (S : String); Do_Fail : Fail_Proc := Osint.Fail'Access; - -- Failing procedure called from procedure Test_If_Relative_Path below. - -- May be redirected. + -- Failing procedure called from procedure Test_If_Relative_Path below. May + -- be redirected. Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data; -- The project tree @@ -74,14 +74,14 @@ package Makeutl is function File_Not_A_Source_Of (Uname : Name_Id; Sfile : File_Name_Type) return Boolean; - -- Check that file name Sfile is one of the source of unit Uname. - -- Returns True if the unit is in one of the project file, but the file - -- name is not one of its source. Returns False otherwise. + -- Check that file name Sfile is one of the source of unit Uname. Returns + -- True if the unit is in one of the project file, but the file name is not + -- one of its source. Returns False otherwise. function Check_Source_Info_In_ALI (The_ALI : ALI.ALI_Id) return Boolean; - -- Check whether all file references in ALI are still valid (ie the source - -- files are still associated with the same units). - -- Return True if everything is still valid + -- Check whether all file references in ALI are still valid (ie the + -- source files are still associated with the same units). Return True + -- if everything is still valid function Is_External_Assignment (Argv : String) return Boolean; -- Verify that an external assignment switch is syntactically correct @@ -92,9 +92,10 @@ package Makeutl is -- -X"name=other value" -- -- Assumptions: 'First = 1, Argv (1 .. 2) = "-X" - -- When this function returns True, the external assignment has - -- been entered by a call to Prj.Ext.Add, so that in a project - -- file, External ("name") will return "value". + -- + -- When this function returns True, the external assignment has been + -- entered by a call to Prj.Ext.Add, so that in a project file, External + -- ("name") will return "value". procedure Verbose_Msg (N1 : Name_Id; @@ -114,6 +115,7 @@ package Makeutl is -- at least equal to Minimum_Verbosity, then print Prefix to standard -- output followed by N1 and S1. If N2 /= No_Name then N2 is printed after -- S1. S2 is printed last. Both N1 and N2 are printed in quotation marks. + -- The two forms differ only in taking Name_Id or File_name_Type arguments. function Linker_Options_Switches (Project : Project_Id; @@ -127,8 +129,8 @@ package Makeutl is -- files exist and that they belong to a project file. function Unit_Index_Of (ALI_File : File_Name_Type) return Int; - -- Find the index of a unit in a source file. Return zero if the file - -- is not a multi-unit source file. + -- Find the index of a unit in a source file. Return zero if the file is + -- not a multi-unit source file. package Mains is @@ -149,8 +151,8 @@ package Makeutl is -- Reset the index to the beginning of the table function Next_Main return String; - -- Increase the index and return the next main. - -- If table is exhausted, return an empty string. + -- Increase the index and return the next main. If table is exhausted, + -- return an empty string. function Get_Location return Source_Ptr; -- Get the location of the current main @@ -170,12 +172,12 @@ package Makeutl is Including_L_Switch : Boolean := True; Including_Non_Switch : Boolean := True; Including_RTS : Boolean := False); - -- Test if Switch is a relative search path switch. - -- If it is, fail if Parent is the empty string, otherwise prepend the path - -- with Parent. This subprogram is only called when using project files. - -- For gnatbind switches, Including_L_Switch is False, because the - -- argument of the -L switch is not a path. If Including_RTS is True, - -- process also switches --RTS=. + -- Test if Switch is a relative search path switch. If it is, fail if + -- Parent is the empty string, otherwise prepend the path with Parent. + -- This subprogram is only called when using project files. For gnatbind + -- switches, Including_L_Switch is False, because the argument of the -L + -- switch is not a path. If Including_RTS is True, process also switches + -- --RTS=. function Path_Or_File_Name (Path : Path_Name_Type) return String; -- Returns a file name if -df is used, otherwise return a path name @@ -185,9 +187,9 @@ package Makeutl is ---------------------- procedure Mark (Source_File : File_Name_Type; Index : Int := 0); - -- Mark a unit, identified by its source file and, when Index is not 0, - -- the index of the unit in the source file. Marking is used to signal - -- that the unit has already been inserted in the Q. + -- Mark a unit, identified by its source file and, when Index is not 0, the + -- index of the unit in the source file. Marking is used to signal that the + -- unit has already been inserted in the Q. function Is_Marked (Source_File : File_Name_Type; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 0f4e050..2ad7903 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -1053,6 +1053,7 @@ package body Prj is ----------------------------------- procedure Compute_All_Imported_Projects (Project : Project_Id) is + procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean); -- Recursively add the projects imported by project Project, but not -- those that are extended. @@ -1070,6 +1071,7 @@ package body Prj is -- A project is not importing itself Prj2 := Ultimate_Extending_Project_Of (Prj); + if Project /= Prj2 then -- Check that the project is not already in the list. We know the @@ -1081,6 +1083,7 @@ package body Prj is if List.Project = Prj2 then return; end if; + List := List.Next; end loop; @@ -1095,6 +1098,7 @@ package body Prj is procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Recursive_Add); + Dummy : Boolean := False; begin diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 5696a1c..84deca1 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4826,20 +4826,21 @@ package body Sem_Ch3 is Parent_Type : Entity_Id; Derived_Type : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); + + Corr_Record : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - Corr_Record : constant Entity_Id - := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); Corr_Decl : Node_Id; Corr_Decl_Needed : Boolean; - -- If the derived type has fewer discriminants than its parent, - -- the corresponding record is also a derived type, in order to - -- account for the bound discriminants. We create a full type - -- declaration for it in this case. + -- If the derived type has fewer discriminants than its parent, the + -- corresponding record is also a derived type, in order to account for + -- the bound discriminants. We create a full type declaration for it in + -- this case. - Constraint_Present : constant Boolean - := Nkind (Subtype_Indication (Type_Definition (N))) - = N_Subtype_Indication; + Constraint_Present : constant Boolean := + Nkind (Subtype_Indication (Type_Definition (N))) = + N_Subtype_Indication; D_Constraint : Node_Id; New_Constraint : Elist_Id; @@ -4867,8 +4868,9 @@ package body Sem_Ch3 is -- The new type has fewer discriminants, so we need to create a new -- corresponding record, which is derived from the corresponding - -- record of the parent, and has a stored constraint that - -- captures the values of the discriminant constraints. + -- record of the parent, and has a stored constraint that captures + -- the values of the discriminant constraints. + -- The type declaration for the derived corresponding record has -- the same discriminant part and constraints as the current -- declaration. Copy the unanalyzed tree to build declaration. @@ -4980,15 +4982,13 @@ package body Sem_Ch3 is while Present (D_Constraint) loop if Nkind (D_Constraint) /= N_Discriminant_Association then - -- Positional constraint. If it is a reference to a - -- new discriminant, it constrains the corresponding - -- old one. + -- Positional constraint. If it is a reference to a new + -- discriminant, it constrains the corresponding old one. if Nkind (D_Constraint) = N_Identifier then New_Disc := First_Discriminant (Derived_Type); while Present (New_Disc) loop - exit when - Chars (New_Disc) = Chars (D_Constraint); + exit when Chars (New_Disc) = Chars (D_Constraint); Next_Discriminant (New_Disc); end loop; @@ -4999,12 +4999,12 @@ package body Sem_Ch3 is Next_Discriminant (Old_Disc); - -- if this is a named constraint, search by name for the - -- old discriminants constrained by the new one. + -- if this is a named constraint, search by name for the old + -- discriminants constrained by the new one. elsif Nkind (Expression (D_Constraint)) = N_Identifier then - -- Find new discriminant with that name. + -- Find new discriminant with that name New_Disc := First_Discriminant (Derived_Type); while Present (New_Disc) loop @@ -5015,20 +5015,17 @@ package body Sem_Ch3 is if Present (New_Disc) then - -- Verify that the new discriminant renames - -- some discriminant of the parent type, and - -- associate the new discriminant with an old - -- one that it renames (may be more than one). + -- Verify that new discriminant renames some discriminant + -- of the parent type, and associate the new discriminant + -- with one or more old ones that it renames. declare Selector : Node_Id; begin Selector := First (Selector_Names (D_Constraint)); - while Present (Selector) loop Old_Disc := First_Discriminant (Parent_Type); - while Present (Old_Disc) loop exit when Chars (Old_Disc) = Chars (Selector); Next_Discriminant (Old_Disc); @@ -5037,7 +5034,6 @@ package body Sem_Ch3 is if Present (Old_Disc) then Set_Corresponding_Discriminant (New_Disc, Old_Disc); - end if; Next (Selector); @@ -5049,21 +5045,20 @@ package body Sem_Ch3 is Next (D_Constraint); end loop; - New_Disc := First_Discriminant (Derived_Type); + New_Disc := First_Discriminant (Derived_Type); while Present (New_Disc) loop if No (Corresponding_Discriminant (New_Disc)) then Error_Msg_NE - ("new discriminant& must constraint old one", - N, New_Disc); + ("new discriminant& must constrain old one", N, New_Disc); + elsif not - Subtypes_Statically_Compatible ( - Etype (New_Disc), - Etype (Corresponding_Discriminant (New_Disc))) + Subtypes_Statically_Compatible + (Etype (New_Disc), + Etype (Corresponding_Discriminant (New_Disc))) then Error_Msg_NE ("& not statically compatible with parent discriminant", N, New_Disc); - end if; Next_Discriminant (New_Disc); @@ -5072,22 +5067,20 @@ package body Sem_Ch3 is elsif Present (Discriminant_Specifications (N)) then Error_Msg_N - ("missing discriminant constraint in untagged derivation", - N); + ("missing discriminant constraint in untagged derivation", N); end if; - -- The entity chain of the derived type includes the new - -- discriminants but shares operations with the parent. + -- The entity chain of the derived type includes the new discriminants + -- but shares operations with the parent. if Present (Discriminant_Specifications (N)) then Old_Disc := First_Discriminant (Parent_Type); while Present (Old_Disc) loop - if No (Next_Entity (Old_Disc)) or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant then - Set_Next_Entity (Last_Entity (Derived_Type), - Next_Entity (Old_Disc)); + Set_Next_Entity + (Last_Entity (Derived_Type), Next_Entity (Old_Disc)); exit; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6497be3..80d4f28 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10448,10 +10448,7 @@ package body Sem_Util is begin -- Deal with indexed or selected component where prefix is modified - if Nkind (N) = N_Indexed_Component - or else - Nkind (N) = N_Selected_Component - then + if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then Pref := Prefix (N); -- If prefix is access type, then it is the designated object that is |