diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 32 | ||||
| -rw-r--r-- | gcc/ada/ali.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/ali.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/makeutl.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/par_sco.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 37 |
11 files changed, 113 insertions, 42 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 80c3358..f69a570 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2014-07-18 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Replace_Type_References_Generic): Use type entity + as a parameter, rather than its Chars field, in order to locate + freeze node of type. If the predicate or invariant has references + to types other than the one to which the contract applies, these + types must be frozen, and the corresponding predicate functions + created, before that freeze node. + +2014-07-18 Robert Dewar <dewar@adacore.com> + + * freeze.adb, einfo.ads, einfo.adb: Minor code reorganization. + * par_sco.adb: Minor reformatting. + +2014-07-18 Gary Dismukes <dismukes@adacore.com> + + * exp_ch4.adb (Real_Range_Check): Turn off + the Do_Range_Check flag on the conversion's current Expression + argument rather than on the originally captured Operand node, + as Expression may reflect a rewriting (as in conversions to a + fixed-point type). + +2014-07-18 Vincent Celier <celier@adacore.com> + + * ali.adb (Scan_ALI): Set Sdep_Record.Unit_Name, when the unit + is not a subunit. + * ali.ads (Sdep_Record): New component Unit_Name. + * lib-writ.adb (Write_ALI): Write the unit name in D lines. + * makeutl.adb (Check_Source_Info_In_ALI): Return False if a + dependent unit is in a project and the source file name is not + one of its sources. + 2014-07-18 Bob Duff <duff@adacore.com> * s-addima.ads: Minor: add comment. diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index b90c5c0..73db0e8 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -2317,9 +2317,10 @@ package body ALI is end if; end; - -- Acquire subunit and reference file name entries + -- Acquire (sub)unit and reference file name entries Sdep.Table (Sdep.Last).Subunit_Name := No_Name; + Sdep.Table (Sdep.Last).Unit_Name := No_Name; Sdep.Table (Sdep.Last).Rfile := Sdep.Table (Sdep.Last).Sfile; Sdep.Table (Sdep.Last).Start_Line := 1; @@ -2327,7 +2328,7 @@ package body ALI is if not At_Eol then Skip_Space; - -- Here for subunit name + -- Here for (sub)unit name if Nextc not in '0' .. '9' then Name_Len := 0; @@ -2335,11 +2336,18 @@ package body ALI is Add_Char_To_Name_Buffer (Getc); end loop; - -- Set the subunit name. Note that we use Name_Find rather + -- Set the (sub)unit name. Note that we use Name_Find rather -- than Name_Enter here as the subunit name may already -- have been put in the name table by the Project Manager. - Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; + if Name_Len <= 2 + or else Name_Buffer (Name_Len - 1) /= '%' + then + Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; + else + Name_Len := Name_Len - 2; + Sdep.Table (Sdep.Last).Unit_Name := Name_Find; + end if; Skip_Space; end if; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 1d7e159..be5f793 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -767,6 +767,9 @@ package ALI is Subunit_Name : Name_Id; -- Name_Id for subunit name if present, else No_Name + Unit_Name : Name_Id; + -- Name_Id for the unit name, if not a subunit. No_Name for a subunit. + Rfile : File_Name_Type; -- Reference file name. Same as Sfile unless a Source_Reference pragma -- was used, in which case it reflects the name used in the pragma. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 79da6f9..a2abb45 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -7017,6 +7017,15 @@ package body Einfo is Ekind (Id) = E_Abstract_State and then Nkind (Parent (Id)) = N_Null; end Is_Null_State; + --------------------- + -- Is_Packed_Array -- + --------------------- + + function Is_Packed_Array (Id : E) return B is + begin + return Is_Array_Type (Id) and then Is_Packed (Id); + end Is_Packed_Array; + ----------------------------------- -- Is_Package_Or_Generic_Package -- ----------------------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 011e10c..42439ad 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2703,6 +2703,9 @@ package Einfo is -- out that the component size is not suitable for bit packing, the -- Is_Packed flag gets turned off. +-- Is_Packed_Array (synth) +-- Applies to all entities, true if entity is for a packed array. + -- Is_Packed_Array_Type (Flag138) -- Defined in all entities. This flag is set on the entity for the type -- used to implement a packed array (either a modular type, or a subtype @@ -6874,6 +6877,7 @@ package Einfo is function Is_Ghost_Subprogram (Id : E) return B; function Is_Null_State (Id : E) return B; function Is_Package_Or_Generic_Package (Id : E) return B; + function Is_Packed_Array (Id : E) return B; function Is_Prival (Id : E) return B; function Is_Protected_Component (Id : E) return B; function Is_Protected_Interface (Id : E) return B; @@ -8634,6 +8638,7 @@ package Einfo is pragma Inline (Base_Type); pragma Inline (Is_Base_Type); pragma Inline (Is_Package_Or_Generic_Package); + pragma Inline (Is_Packed_Array); pragma Inline (Is_Volatile); pragma Inline (Is_Wrapper_Package); pragma Inline (Known_RM_Size); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 917f98a..725efab 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -10191,7 +10191,13 @@ package body Exp_Ch4 is and then S_Lov >= D_Lov and then S_Hiv <= D_Hiv then - Set_Do_Range_Check (Operand, False); + -- Unset the range check flag on the current value of + -- Expression (N), since the captured Operand may have + -- been rewritten (such as for the case of a conversion + -- to a fixed-point type). + + Set_Do_Range_Check (Expression (N), False); + return; end if; end; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index ab0334e..fb35942 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1095,20 +1095,6 @@ package body Freeze is Component_Aliased : Boolean; - function Is_Packed_Array (T : Entity_Id) return Boolean; - -- True for a packed array type - - --------------------- - -- Is_Packed_Array -- - --------------------- - - function Is_Packed_Array (T : Entity_Id) return Boolean is - begin - return Is_Array_Type (T) and then Is_Packed (T); - end Is_Packed_Array; - - -- Start of processing for Check_Component_Storage_Order - begin -- Record case @@ -1121,10 +1107,9 @@ package body Freeze is Component_Aliased := False; else - -- If a component clause is present, check whether component - -- starts on a storage element boundary. Otherwise conservatively - -- assume it does so only in the case where the record is not - -- packed. + -- If a component clause is present, check if the component starts + -- on a storage element boundary. Otherwise conservatively assume + -- it does so only in the case where the record is not packed. if Present (Component_Clause (Comp)) then Comp_Byte_Aligned := diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index df57c65..1240032 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -1429,12 +1429,15 @@ package body Lib.Writ is -- If subunit, add unit name, omitting the %b at the end - if Present (Cunit (Unum)) - and then Nkind (Unit (Cunit (Unum))) = N_Subunit - then + if Present (Cunit (Unum)) then Get_Decoded_Name_String (Unit_Name (Unum)); Write_Info_Char (' '); - Write_Info_Str (Name_Buffer (1 .. Name_Len - 2)); + + if Nkind (Unit (Cunit (Unum))) = N_Subunit then + Write_Info_Str (Name_Buffer (1 .. Name_Len - 2)); + else + Write_Info_Str (Name_Buffer (1 .. Name_Len)); + end if; end if; -- If Source_Reference pragma used, output information diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 4518959..36b1c6a 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -320,6 +320,15 @@ package body Makeutl is end; end if; + Unit_Name := SD.Unit_Name; + + if Unit_Name /= No_Name + and then not Fname.Is_Internal_File_Name (SD.Sfile) + and then File_Not_A_Source_Of (Tree, Unit_Name, SD.Sfile) + then + return No_Name; + end if; + else -- For separates, the file is no longer associated with the -- unit ("proc-sep.adb" is not associated with unit "proc.sep") diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 215a81a..15382ac 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -308,8 +308,8 @@ package body Par_SCO is function Check_Node (N : Node_Id) return Traverse_Result; -- Determine if Nkind (N) indicates the presence of a decision (i.e. - -- N is a logical operator -- a decision in itelsf -- or an - -- IF-expression -- whose Condition attribute is a decision). + -- N is a logical operator, which is a decision in itself, or an + -- IF-expression whose Condition attribute is a decision). ---------------- -- Check_Node -- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 317510a..fe54f88 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -33,6 +33,7 @@ with Errout; use Errout; with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Namet; use Namet; @@ -155,14 +156,14 @@ package body Sem_Ch13 is generic with procedure Replace_Type_Reference (N : Node_Id); - procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id); + procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id); -- This is used to scan an expression for a predicate or invariant aspect - -- replacing occurrences of the name TName (the name of the subtype to - -- which the aspect applies) with appropriate references to the parameter - -- of the predicate function or invariant procedure. The procedure passed - -- as a generic parameter does the actual replacement of node N, which is - -- either a simple direct reference to TName, or a selected component that - -- represents an appropriately qualified occurrence of TName. + -- replacing occurrences of the name of the subtype to which the aspect + -- applies with appropriate references to the parameter of the predicate + -- function or invariant procedure. The procedure passed as a generic + -- parameter does the actual replacement of node N, which is either a + -- simple direct reference to T, or a selected component that represents + -- an appropriately qualified occurrence of T. procedure Resolve_Iterable_Operation (N : Node_Id; @@ -7216,7 +7217,7 @@ package body Sem_Ch13 is -- with references to the object, converted to type'Class in -- the case of Invariant'Class aspects. - Replace_Type_References (Exp, Chars (T)); + Replace_Type_References (Exp, T); -- If this invariant comes from an aspect, find the aspect -- specification, and replace the saved expression because @@ -7268,7 +7269,7 @@ package body Sem_Ch13 is Inv : constant Node_Id := Expression (Corresponding_Aspect (Ritem)); begin - Replace_Type_References (Inv, Chars (T)); + Replace_Type_References (Inv, T); Preanalyze_Assert_Expression (Inv, Standard_Boolean); end; end if; @@ -7656,7 +7657,7 @@ package body Sem_Ch13 is -- We need to replace any occurrences of the name of the -- type with references to the object. - Replace_Type_References (Arg2, Chars (Typ)); + Replace_Type_References (Arg2, Typ); -- If this predicate comes from an aspect, find the aspect -- specification, and replace the saved expression because @@ -10303,7 +10304,7 @@ package body Sem_Ch13 is Replace (N, Make_Null_Statement (Sloc (N))); -- The null statement must be marked as not coming from source. This is - -- so that ASIS ignores if, and also the back end does not expect bogus + -- so that ASIS ignores it, and also the back end does not expect bogus -- "from source" null statements in weird places (e.g. in declarative -- regions where such null statements are not allowed). @@ -10837,7 +10838,8 @@ package body Sem_Ch13 is -- Replace_Type_References_Generic -- ------------------------------------- - procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is + procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id) is + TName : constant Name_Id := Chars (T); function Replace_Node (N : Node_Id) return Traverse_Result; -- Processes a single node in the traversal procedure below, checking @@ -10859,9 +10861,18 @@ package body Sem_Ch13 is if Nkind (N) = N_Identifier then - -- If not the type name, all done with this node + -- If not the type name, check whether it is a reference to + -- some other type, which must be frozen before the predicate + -- function is analyzed, i.e. before the freeze node of the + -- type to which the predicate applies. if Chars (N) /= TName then + if Present (Current_Entity (N)) + and then Is_Type (Current_Entity (N)) + then + Freeze_Before (Freeze_Node (T), Current_Entity (N)); + end if; + return Skip; -- Otherwise do the replacement and we are done with this node |