From 7f5e671bce70f537708f36033cd44869ca94fb4c Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Mon, 9 Oct 2017 20:28:22 +0000 Subject: [PATCH] [multiple changes] 2017-10-09 Justin Squirek * sem_ch3.adb: Rename Uses_Unseen_Priv into Contains_Lib_Incomplete_Type. 2017-10-09 Hristian Kirtchev * sem_aggr.adb, sem_spark.adb, adabkend.adb, exp_ch5.adb, frontend.adb, sem_ch12.adb, fmap.adb, exp_ch6.adb, exp_spark.adb, lib-load.adb, exp_ch9.adb, osint.adb, exp_disp.adb, sem_ch8.adb, sem_ch8.ads, prepcomp.adb, gnat1drv.adb, atree.adb, sinput-l.adb, targparm.adb, sem_ch10.adb, par-ch8.adb: Minor reformatting. From-SVN: r253566 --- gcc/ada/ChangeLog | 13 +++ gcc/ada/adabkend.adb | 4 +- gcc/ada/atree.adb | 11 ++- gcc/ada/exp_ch5.adb | 2 +- gcc/ada/exp_ch6.adb | 4 +- gcc/ada/exp_ch9.adb | 1 + gcc/ada/exp_disp.adb | 13 +-- gcc/ada/exp_spark.adb | 75 ++++++++-------- gcc/ada/fmap.adb | 1 + gcc/ada/frontend.adb | 1 + gcc/ada/gnat1drv.adb | 1 + gcc/ada/lib-load.adb | 14 ++- gcc/ada/osint.adb | 4 - gcc/ada/par-ch8.adb | 4 +- gcc/ada/prepcomp.adb | 15 ++-- gcc/ada/sem_aggr.adb | 5 +- gcc/ada/sem_ch10.adb | 20 +++-- gcc/ada/sem_ch12.adb | 38 ++++---- gcc/ada/sem_ch3.adb | 85 +++++++++--------- gcc/ada/sem_ch8.adb | 196 +++++++++++++++++++++++------------------- gcc/ada/sem_ch8.ads | 20 ++--- gcc/ada/sem_spark.adb | 4 +- gcc/ada/sinput-l.adb | 4 +- gcc/ada/targparm.adb | 4 +- 24 files changed, 299 insertions(+), 240 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 20d60c38bf2..99d0702f022 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2017-10-09 Justin Squirek + + * sem_ch3.adb: Rename Uses_Unseen_Priv into + Contains_Lib_Incomplete_Type. + +2017-10-09 Hristian Kirtchev + + * sem_aggr.adb, sem_spark.adb, adabkend.adb, exp_ch5.adb, frontend.adb, + sem_ch12.adb, fmap.adb, exp_ch6.adb, exp_spark.adb, lib-load.adb, + exp_ch9.adb, osint.adb, exp_disp.adb, sem_ch8.adb, sem_ch8.ads, + prepcomp.adb, gnat1drv.adb, atree.adb, sinput-l.adb, targparm.adb, + sem_ch10.adb, par-ch8.adb: Minor reformatting. + 2017-10-09 Hristian Kirtchev * sem_elab.adb (Is_Suitable_Access): This scenario is now only relevant diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb index 2ab4b19a1d8..ae0218e04de 100644 --- a/gcc/ada/adabkend.adb +++ b/gcc/ada/adabkend.adb @@ -59,8 +59,8 @@ package body Adabkend is -- The front end leaves the Current_Error_Node at a location that is -- meaningless and confusing when emitting bug boxes from the back end. - -- By resetting it here we default to "No source file position - -- information available" message on back end crashes. + -- Reset the global variable in order to emit "No source file position + -- information available" messages on back end crashes. Current_Error_Node := Empty; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index f5a00991768..1a7e36ca70d 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -741,6 +741,7 @@ package body Atree is begin pragma Debug (New_Node_Debugging_Output (Source)); pragma Debug (New_Node_Debugging_Output (Destination)); + Nodes.Table (Destination) := Nodes.Table (Source); Nodes.Table (Destination).In_List := Save_In_List; Nodes.Table (Destination).Link := Save_Link; @@ -1330,6 +1331,7 @@ package body Atree is begin pragma Debug (New_Node_Debugging_Output (E1)); pragma Debug (New_Node_Debugging_Output (E2)); + pragma Assert (True and then Has_Extension (E1) and then Has_Extension (E2) @@ -1402,8 +1404,10 @@ package body Atree is begin pragma Assert (not (Has_Extension (Node))); + Result := Allocate_Initialize_Node (Node, With_Extension => True); pragma Debug (Debug_Extend_Node); + return Result; end Extend_Node; @@ -1677,8 +1681,8 @@ package body Atree is Current_Error_Node := Ent; end if; - Nodes.Table (Ent).Nkind := New_Node_Kind; - Nodes.Table (Ent).Sloc := New_Sloc; + Nodes.Table (Ent).Nkind := New_Node_Kind; + Nodes.Table (Ent).Sloc := New_Sloc; pragma Debug (New_Node_Debugging_Output (Ent)); -- Mark the new entity as Ghost depending on the current Ghost region @@ -1700,6 +1704,7 @@ package body Atree is begin pragma Assert (New_Node_Kind not in N_Entity); + Nod := Allocate_Initialize_Node (Empty, With_Extension => False); Nodes.Table (Nod).Nkind := New_Node_Kind; Nodes.Table (Nod).Sloc := New_Sloc; @@ -2144,6 +2149,7 @@ package body Atree is (not Has_Extension (Old_Node) and not Has_Extension (New_Node) and not Nodes.Table (New_Node).In_List); + pragma Debug (New_Node_Debugging_Output (Old_Node)); pragma Debug (New_Node_Debugging_Output (New_Node)); @@ -2197,6 +2203,7 @@ package body Atree is (not Has_Extension (Old_Node) and not Has_Extension (New_Node) and not Nodes.Table (New_Node).In_List); + pragma Debug (New_Node_Debugging_Output (Old_Node)); pragma Debug (New_Node_Debugging_Output (New_Node)); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 5846874fc30..d760739d057 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1577,7 +1577,7 @@ package body Exp_Ch5 is -- suppressed in this case). It is unnecessary but harmless in -- other cases. - -- Special case: no copy if the target has no discriminants. + -- Special case: no copy if the target has no discriminants if Has_Discriminants (L_Typ) and then Is_Unchecked_Union (Base_Type (L_Typ)) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c9ec0da0454..1b648ff6ad4 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3001,8 +3001,8 @@ package body Exp_Ch6 is if Prev_Orig /= Prev and then Nkind (Prev) = N_Attribute_Reference - and then - Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access + and then Get_Attribute_Id (Attribute_Name (Prev)) = + Attribute_Access and then Is_Aliased_View (Prev_Orig) then Prev_Orig := Prev; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 17687c05c56..aca0c18e3b6 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6041,6 +6041,7 @@ package body Exp_Ch9 is -- reference will have been rewritten. if Expander_Active then + -- The expanded name may have been constant folded in which case -- the original node is not necessarily an entity name (e.g. an -- indexed component). diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 69d296543e2..f3728f655d4 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -323,7 +323,7 @@ package body Exp_Disp is and then not Is_Interface (Full_Typ) and then Has_Interfaces (Full_Typ) and then (Full_Typ = Root_Typ - or else not Is_Variable_Size_Record (Etype (Full_Typ))); + or else not Is_Variable_Size_Record (Etype (Full_Typ))); end Building_Static_Secondary_DT; ---------------------------------- @@ -4787,7 +4787,8 @@ package body Exp_Disp is if Is_Discrete_Type (Etype (Discrim)) then Append_To (Constr_List, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etype (Discrim), Loc), + Prefix => + New_Occurrence_Of (Etype (Discrim), Loc), Attribute_Name => Name_First)); else @@ -4850,12 +4851,12 @@ package body Exp_Disp is Make_Secondary_DT (Typ => Typ, - Iface => Base_Type - (Related_Type (Node (AI_Tag_Comp))), + Iface => + Base_Type (Related_Type (Node (AI_Tag_Comp))), Iface_Comp => Node (AI_Tag_Comp), Suffix_Index => Suffix_Index, - Num_Iface_Prims => UI_To_Int - (DT_Entry_Count (Node (AI_Tag_Comp))), + Num_Iface_Prims => + UI_To_Int (DT_Entry_Count (Node (AI_Tag_Comp))), Iface_DT_Ptr => Node (AI_Tag_Elmt), Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), Build_Thunks => True, diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 9383c1c65e6..5386fa6578b 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -55,10 +55,10 @@ package body Exp_SPARK is -- Replace occurrences of System'To_Address by calls to -- System.Storage_Elements.To_Address - procedure Expand_SPARK_Freeze_Type (E : Entity_Id); + procedure Expand_SPARK_N_Freeze_Type (E : Entity_Id); -- Build the DIC procedure of a type when needed, if not already done - procedure Expand_SPARK_Indexed_Component (N : Node_Id); + procedure Expand_SPARK_N_Indexed_Component (N : Node_Id); -- Insert explicit dereference if required procedure Expand_SPARK_N_Loop_Statement (N : Node_Id); @@ -73,7 +73,7 @@ package body Exp_SPARK is procedure Expand_SPARK_N_Op_Ne (N : Node_Id); -- Rewrite operator /= based on operator = when defined explicitly - procedure Expand_SPARK_Selected_Component (N : Node_Id); + procedure Expand_SPARK_N_Selected_Component (N : Node_Id); -- Insert explicit dereference if required ------------------ @@ -134,14 +134,14 @@ package body Exp_SPARK is when N_Freeze_Entity => if Is_Type (Entity (N)) then - Expand_SPARK_Freeze_Type (Entity (N)); + Expand_SPARK_N_Freeze_Type (Entity (N)); end if; when N_Indexed_Component => - Expand_SPARK_Indexed_Component (N); + Expand_SPARK_N_Indexed_Component (N); when N_Selected_Component => - Expand_SPARK_Selected_Component (N); + Expand_SPARK_N_Selected_Component (N); -- In SPARK mode, no other constructs require expansion @@ -150,11 +150,11 @@ package body Exp_SPARK is end case; end Expand_SPARK; - ------------------------------ - -- Expand_SPARK_Freeze_Type -- - ------------------------------ + -------------------------------- + -- Expand_SPARK_N_Freeze_Type -- + -------------------------------- - procedure Expand_SPARK_Freeze_Type (E : Entity_Id) is + procedure Expand_SPARK_N_Freeze_Type (E : Entity_Id) is begin -- When a DIC is inherited by a tagged type, it may need to be -- specialized to the descendant type, hence build a separate DIC @@ -163,7 +163,7 @@ package body Exp_SPARK is if Has_DIC (E) and then Is_Tagged_Type (E) then Build_DIC_Procedure_Body (E, For_Freeze => True); end if; - end Expand_SPARK_Freeze_Type; + end Expand_SPARK_N_Freeze_Type; ---------------------------------------- -- Expand_SPARK_N_Attribute_Reference -- @@ -292,19 +292,20 @@ package body Exp_SPARK is end if; end Expand_SPARK_N_Loop_Statement; - ------------------------------------ - -- Expand_SPARK_Indexed_Component -- - ------------------------------------ + -------------------------------------- + -- Expand_SPARK_N_Indexed_Component -- + -------------------------------------- + + procedure Expand_SPARK_N_Indexed_Component (N : Node_Id) is + Pref : constant Node_Id := Prefix (N); + Typ : constant Entity_Id := Etype (Pref); - procedure Expand_SPARK_Indexed_Component (N : Node_Id) is - P : constant Node_Id := Prefix (N); - T : constant Entity_Id := Etype (P); begin - if Is_Access_Type (T) then - Insert_Explicit_Dereference (P); - Analyze_And_Resolve (P, Designated_Type (T)); + if Is_Access_Type (Typ) then + Insert_Explicit_Dereference (Pref); + Analyze_And_Resolve (Pref, Designated_Type (Typ)); end if; - end Expand_SPARK_Indexed_Component; + end Expand_SPARK_N_Indexed_Component; --------------------------------------- -- Expand_SPARK_N_Object_Declaration -- @@ -496,31 +497,31 @@ package body Exp_SPARK is end if; end Expand_SPARK_Potential_Renaming; - ------------------------------------- - -- Expand_SPARK_Selected_Component -- - ------------------------------------- + --------------------------------------- + -- Expand_SPARK_N_Selected_Component -- + --------------------------------------- + + procedure Expand_SPARK_N_Selected_Component (N : Node_Id) is + Pref : constant Node_Id := Prefix (N); + Typ : constant Entity_Id := Underlying_Type (Etype (Pref)); - procedure Expand_SPARK_Selected_Component (N : Node_Id) is - P : constant Node_Id := Prefix (N); - Ptyp : constant Entity_Id := Underlying_Type (Etype (P)); begin - if Present (Ptyp) - and then Is_Access_Type (Ptyp) - then + if Present (Typ) and then Is_Access_Type (Typ) then + -- First set prefix type to proper access type, in case it currently -- has a private (non-access) view of this type. - Set_Etype (P, Ptyp); + Set_Etype (Pref, Typ); - Insert_Explicit_Dereference (P); - Analyze_And_Resolve (P, Designated_Type (Ptyp)); + Insert_Explicit_Dereference (Pref); + Analyze_And_Resolve (Pref, Designated_Type (Typ)); - if Ekind (Etype (P)) = E_Private_Subtype - and then Is_For_Access_Subtype (Etype (P)) + if Ekind (Etype (Pref)) = E_Private_Subtype + and then Is_For_Access_Subtype (Etype (Pref)) then - Set_Etype (P, Base_Type (Etype (P))); + Set_Etype (Pref, Base_Type (Etype (Pref))); end if; end if; - end Expand_SPARK_Selected_Component; + end Expand_SPARK_N_Selected_Component; end Exp_SPARK; diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index 4345dfa8005..2b95dc7be7d 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -306,6 +306,7 @@ package body Fmap is else Write_Str ("warning: no read access for mapping file """); end if; + Write_Str (File_Name); Write_Line (""""); No_Mapping_File := True; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index b19da897332..828f6ff2999 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -169,6 +169,7 @@ begin -- Case of gnat.adc file present if Source_gnat_adc > No_Source_File then + -- Parse the gnat.adc file for configuration pragmas Initialize_Scanner (No_Unit, Source_gnat_adc); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 882631f9bee..4bf910bca3e 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -1065,6 +1065,7 @@ begin ("fatal error, run-time library not installed correctly"); Write_Line ("cannot locate file system.ads"); raise Unrecoverable_Error; + elsif S = No_Access_To_Source_File then Write_Line ("fatal error, run-time library not installed correctly"); diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 1419422887f..977567d4983 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -328,19 +328,23 @@ package body Lib.Load is if Main_Source_File > No_Source_File then Version := Source_Checksum (Main_Source_File); + else -- To avoid emitting a source location (since there is no file), -- we write a custom error message instead of using the machinery -- in errout.adb. Set_Standard_Error; + if Main_Source_File = No_Access_To_Source_File then - Write_Str ("no read access for file """ - & Get_Name_String (Fname) & """"); + Write_Str + ("no read access for file """ & Get_Name_String (Fname) + & """"); else - Write_Str ("file """ - & Get_Name_String (Fname) & """ not found"); + Write_Str + ("file """ & Get_Name_String (Fname) & """ not found"); end if; + Write_Eol; Set_Standard_Output; end if; @@ -835,6 +839,7 @@ package body Lib.Load is else Write_Str (" file was not found, load failed"); end if; + Write_Eol; end if; @@ -867,6 +872,7 @@ package body Lib.Load is else Error_Msg_File_1 := Fname; + if Src_Ind = No_Access_To_Source_File then Error_Msg ("no read access to file{", Load_Msg_Sloc); else diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 781db47d0af..14fbba51152 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -2568,10 +2568,6 @@ package body Osint is FD : out File_Descriptor; T : File_Type := Source) is - -- Source_File_FD : File_Descriptor; - -- The file descriptor for the current source file. A negative value - -- indicates failure to open the specified source file. - Len : Integer; -- Length of file, assume no more than 2 gigabytes of source diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb index 456c86358be..4dea281647a 100644 --- a/gcc/ada/par-ch8.adb +++ b/gcc/ada/par-ch8.adb @@ -65,6 +65,7 @@ package body Ch8 is Append (Use_Node, Item_List); Is_Last := True; + else Set_More_Ids (Use_Node); @@ -152,11 +153,12 @@ package body Ch8 is -- Error recovery: cannot raise Error_Resync procedure P_Use_Type_Clause (Item_List : List_Id) is + Use_Sloc : constant Source_Ptr := Prev_Token_Ptr; + All_Present : Boolean; Is_First : Boolean := True; Is_Last : Boolean := False; Use_Node : Node_Id; - Use_Sloc : constant Source_Ptr := Prev_Token_Ptr; begin if Token = Tok_All then diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb index 7c56130c113..320d62222d3 100644 --- a/gcc/ada/prepcomp.adb +++ b/gcc/ada/prepcomp.adb @@ -630,17 +630,16 @@ package body Prepcomp is String_To_Name_Buffer (Current_Data.Deffile); declare - N : constant File_Name_Type := Name_Find; - Deffile : constant Source_File_Index := - Load_Definition_File (N); - Add_Deffile : Boolean := True; - T : constant Nat := Total_Errors_Detected; + N : constant File_Name_Type := Name_Find; + Deffile : constant Source_File_Index := Load_Definition_File (N); + T : constant Nat := Total_Errors_Detected; + + Add_Deffile : Boolean := True; begin if Deffile <= No_Source_File then - Fail ("definition file """ - & Get_Name_String (N) - & """ not found"); + Fail + ("definition file """ & Get_Name_String (N) & """ not found"); end if; -- Initialize the preprocessor and set the characteristics of the diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index e361bacaa14..b2bd32c6b82 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -4144,8 +4144,9 @@ package body Sem_Aggr is Assoc := First (Component_Associations (N)); while Present (Assoc) loop if Nkind (Assoc) = N_Iterated_Component_Association then - Error_Msg_N ("iterated component association can only " - & "appear in an array aggregate", N); + Error_Msg_N + ("iterated component association can only appear in an " + & "array aggregate", N); raise Unrecoverable_Error; else diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index b89d8d32008..0616a201b79 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -163,7 +163,9 @@ package body Sem_Ch10 is -- the private declarations of a parent unit. procedure Install_Parents - (Lib_Unit : Node_Id; Is_Private : Boolean; Chain : Boolean := True); + (Lib_Unit : Node_Id; + Is_Private : Boolean; + Chain : Boolean := True); -- This procedure establishes the context for the compilation of a child -- unit. If Lib_Unit is a child library spec then the context of the parent -- is installed, and the parent itself made immediately visible, so that @@ -3390,7 +3392,9 @@ package body Sem_Ch10 is if Is_Child_Spec (Lib_Unit) then Install_Parents - (Lib_Unit, Private_Present (Parent (Lib_Unit)), Chain); + (Lib_Unit => Lib_Unit, + Is_Private => Private_Present (Parent (Lib_Unit)), + Chain => Chain); end if; Install_Limited_Context_Clauses (N); @@ -4065,7 +4069,10 @@ package body Sem_Ch10 is --------------------- procedure Install_Parents - (Lib_Unit : Node_Id; Is_Private : Boolean; Chain : Boolean := True) is + (Lib_Unit : Node_Id; + Is_Private : Boolean; + Chain : Boolean := True) + is P : Node_Id; E_Name : Entity_Id; P_Name : Entity_Id; @@ -4121,8 +4128,11 @@ package body Sem_Ch10 is -- This is the recursive call that ensures all parents are loaded if Is_Child_Spec (P) then - Install_Parents (P, - Is_Private or else Private_Present (Parent (Lib_Unit)), Chain); + Install_Parents + (Lib_Unit => P, + Is_Private => + Is_Private or else Private_Present (Parent (Lib_Unit)), + Chain => Chain); end if; -- Now we can install the context for this parent diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 9f538e06438..223703d2a43 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1930,7 +1930,7 @@ package body Sem_Ch12 is procedure Check_Generic_Parent is Inst : constant Node_Id := - Next (Unit_Declaration_Node (Actual)); + Next (Unit_Declaration_Node (Actual)); Par : Entity_Id; begin @@ -1939,26 +1939,26 @@ package body Sem_Ch12 is if Nkind (Parent (Actual)) = N_Package_Specification then Par := Scope (Generic_Parent (Parent (Actual))); + if Is_Generic_Instance (Par) then null; -- If the actual is a child generic unit, check -- whether the instantiation of the parent is - -- also local and must also be frozen now. - -- We must retrieve the instance node to locate - -- the parent instance if any. + -- also local and must also be frozen now. We + -- must retrieve the instance node to locate the + -- parent instance if any. elsif Ekind (Par) = E_Generic_Package - and then Is_Child_Unit (Gen_Par) - and then Ekind (Scope (Gen_Par)) - = E_Generic_Package + and then Is_Child_Unit (Gen_Par) + and then Ekind (Scope (Gen_Par)) = + E_Generic_Package then if Nkind (Inst) = N_Package_Instantiation - and then - Nkind (Name (Inst)) = N_Expanded_Name + and then Nkind (Name (Inst)) = + N_Expanded_Name then - - -- Retrieve entity of psarent instance. + -- Retrieve entity of parent instance Par := Entity (Prefix (Name (Inst))); end if; @@ -1986,12 +1986,13 @@ package body Sem_Ch12 is begin if Present (Renamed_Entity (Actual)) then Gen_Par := - Generic_Parent (Specification ( - Unit_Declaration_Node ( - Renamed_Entity (Actual)))); + Generic_Parent (Specification + (Unit_Declaration_Node + (Renamed_Entity (Actual)))); else - Gen_Par := Generic_Parent - (Specification (Unit_Declaration_Node (Actual))); + Gen_Par := + Generic_Parent (Specification + (Unit_Declaration_Node (Actual))); end if; if not Expander_Active @@ -2036,12 +2037,13 @@ package body Sem_Ch12 is -- that it is the instance that must be frozen. if Nkind (Parent (Actual)) = - N_Package_Renaming_Declaration + N_Package_Renaming_Declaration then Set_Has_Delayed_Freeze (Renamed_Entity (Actual)); Append_Elmt - (Renamed_Entity (Actual), Actuals_To_Freeze); + (Renamed_Entity (Actual), + Actuals_To_Freeze); else Set_Has_Delayed_Freeze (Actual); Append_Elmt (Actual, Actuals_To_Freeze); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2e4134cc3f5..61d1140e9b0 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2211,6 +2211,12 @@ package body Sem_Ch3 is -- contract expression. Full analysis of the expression is done when -- the contract is processed. + function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean; + -- Check if a nested package has entities within it that rely on library + -- level private types where the full view has not been completed for + -- the purposes of checking if it is acceptable to freeze an expression + -- function at the point of declaration. + procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id); -- Determine whether Body_Decl denotes the body of a late controlled -- primitive (either Initialize, Adjust or Finalize). If this is the @@ -2234,12 +2240,6 @@ package body Sem_Ch3 is -- declarations, or before a declaration that freezes previous entities, -- such as in a subprogram body. - function Uses_Unseen_Priv (Pkg : Entity_Id) return Boolean; - -- Check if a nested package has entities within it that rely on library - -- level private types where the full view has not been seen for the - -- purposes of checking if it is acceptable to freeze an expression - -- function at the point of declaration. - ----------------- -- Adjust_Decl -- ----------------- @@ -2400,6 +2400,40 @@ package body Sem_Ch3 is end loop; end Check_Entry_Contracts; + ---------------------------------- + -- Contains_Lib_Incomplete_Type -- + ---------------------------------- + + function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean is + Curr : Entity_Id; + + begin + -- Avoid looking through scopes that do not meet the precondition of + -- Pkg not being within a library unit spec. + + if not Is_Compilation_Unit (Pkg) + and then not Is_Generic_Instance (Pkg) + and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg)) + then + -- Loop through all entities in the current scope to identify + -- an entity that depends on a private type. + + Curr := First_Entity (Pkg); + loop + if Nkind (Curr) in N_Entity + and then Depends_On_Private (Curr) + then + return True; + end if; + + exit when Last_Entity (Current_Scope) = Curr; + Curr := Next_Entity (Curr); + end loop; + end if; + + return False; + end Contains_Lib_Incomplete_Type; + -------------------------------------- -- Handle_Late_Controlled_Primitive -- -------------------------------------- @@ -2543,40 +2577,6 @@ package body Sem_Ch3 is end loop; end Resolve_Aspects; - ---------------------- - -- Uses_Unseen_Priv -- - ---------------------- - - function Uses_Unseen_Priv (Pkg : Entity_Id) return Boolean is - Curr : Entity_Id; - - begin - -- Avoid looking through scopes that do not meet the precondition of - -- Pkg not being within a library unit spec. - - if not Is_Compilation_Unit (Pkg) - and then not Is_Generic_Instance (Pkg) - and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg)) - then - -- Loop through all entities in the current scope to identify - -- an entity that depends on a private type. - - Curr := First_Entity (Pkg); - loop - if Nkind (Curr) in N_Entity - and then Depends_On_Private (Curr) - then - return True; - end if; - - exit when Last_Entity (Current_Scope) = Curr; - Curr := Next_Entity (Curr); - end loop; - end if; - - return False; - end Uses_Unseen_Priv; - -- Local variables Context : Node_Id := Empty; @@ -2750,7 +2750,7 @@ package body Sem_Ch3 is -- not cause unwanted freezing at that point. -- It is also necessary to check for a case where both an expression - -- function is used and the current scope depends on an unseen + -- function is used and the current scope depends on an incomplete -- private type from a library unit, otherwise premature freezing of -- the private type will occur. @@ -2758,7 +2758,8 @@ package body Sem_Ch3 is and then ((Nkind (Next_Decl) /= N_Subprogram_Body or else not Was_Expression_Function (Next_Decl)) or else (not Is_Ignored_Ghost_Entity (Current_Scope) - and then not Uses_Unseen_Priv (Current_Scope))) + and then not Contains_Lib_Incomplete_Type + (Current_Scope))) then -- When a controlled type is frozen, the expander generates stream -- and controlled-type support routines. If the freeze is caused diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 26714c87c87..aa53045498b 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -479,6 +479,7 @@ package body Sem_Ch8 is -- Find the most previous use clause (that is, the first one to appear in -- the source) by traversing the previous clause chain that exists in both -- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes. + -- ??? a better subprogram name is in order function Find_Renamed_Entity (N : Node_Id; @@ -526,19 +527,24 @@ package body Sem_Ch8 is Clause2 : Entity_Id) return Entity_Id; -- Determine which use clause parameter is the most descendant in terms of -- scope. + -- ??? a better subprogram name is in order procedure Premature_Usage (N : Node_Id); -- Diagnose usage of an entity before it is visible procedure Use_One_Package - (N : Node_Id; Pack_Name : Entity_Id := Empty; Force : Boolean := False); + (N : Node_Id; + Pack_Name : Entity_Id := Empty; + Force : Boolean := False); -- Make visible entities declared in package P potentially use-visible -- in the current context. Also used in the analysis of subunits, when -- re-installing use clauses of parent units. N is the use_clause that -- names P (and possibly other packages). procedure Use_One_Type - (Id : Node_Id; Installed : Boolean := False; Force : Boolean := False); + (Id : Node_Id; + Installed : Boolean := False; + Force : Boolean := False); -- Id is the subtype mark from a use_type_clause. This procedure makes -- the primitive operators of the type potentially use-visible. The -- boolean flag Installed indicates that the clause is being reinstalled @@ -3639,8 +3645,8 @@ package body Sem_Ch8 is -- implicit generic actual. if From_Default (N) - and then Is_Generic_Actual_Subprogram (New_S) - and then Present (Alias (New_S)) + and then Is_Generic_Actual_Subprogram (New_S) + and then Present (Alias (New_S)) then Mark_Use_Clauses (Alias (New_S)); @@ -3666,7 +3672,6 @@ package body Sem_Ch8 is -- within the package itself, ignore it. procedure Analyze_Use_Package (N : Node_Id; Chain : Boolean := True) is - procedure Analyze_Package_Name (Clause : Node_Id); -- Perform analysis on a package name from a use_package_clause @@ -3700,8 +3705,8 @@ package body Sem_Ch8 is if Entity (Pref) = Standard_Standard then Error_Msg_N - ("predefined package Standard cannot appear in a " - & "context clause", Pref); + ("predefined package Standard cannot appear in a context " + & "clause", Pref); end if; end if; end Analyze_Package_Name; @@ -3763,6 +3768,7 @@ package body Sem_Ch8 is if not More_Ids (N) and then not Prev_Ids (N) then Analyze_Package_Name (N); + elsif More_Ids (N) and then not Prev_Ids (N) then Analyze_Package_Name_List (N); end if; @@ -3772,12 +3778,13 @@ package body Sem_Ch8 is return; end if; - Pack := Entity (Name (N)); if Chain then Chain_Use_Clause (N); end if; + Pack := Entity (Name (N)); + -- There are many cases where scopes are manipulated during analysis, so -- check that Pack's current use clause has not already been chained -- before setting its previous use clause. @@ -3796,8 +3803,7 @@ package body Sem_Ch8 is if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then if Ekind (Pack) = E_Generic_Package then Error_Msg_N -- CODEFIX - ("a generic package is not allowed in a use clause", - Name (N)); + ("a generic package is not allowed in a use clause", Name (N)); elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package) then @@ -3807,8 +3813,7 @@ package body Sem_Ch8 is elsif Ekind_In (Pack, E_Function, E_Procedure, E_Operator) then Error_Msg_N -- CODEFIX - ("a subprogram is not allowed in a use clause", - Name (N)); + ("a subprogram is not allowed in a use clause", Name (N)); else Error_Msg_N ("& is not allowed in a use clause", Name (N)); @@ -4186,8 +4191,8 @@ package body Sem_Ch8 is ---------------------- procedure Chain_Use_Clause (N : Node_Id) is - Pack : Entity_Id; Level : Int := Scope_Stack.Last; + Pack : Entity_Id; begin -- Common case @@ -4209,6 +4214,7 @@ package body Sem_Ch8 is -- parent unit when compiling a child. Pack := Defining_Entity (Parent (N), Empty_On_Errors => True); + if not In_Open_Scopes (Pack) then null; @@ -4771,9 +4777,7 @@ package body Sem_Ch8 is function Entity_Of_Unit (U : Node_Id) return Entity_Id is begin - if Nkind (U) = N_Package_Instantiation - and then Analyzed (U) - then + if Nkind (U) = N_Package_Instantiation and then Analyzed (U) then return Defining_Entity (Instance_Spec (U)); else return Defining_Entity (U); @@ -5885,9 +5889,7 @@ package body Sem_Ch8 is -- path, so ignore the fact that they are overloaded and mark them -- anyway. - if Nkind (N) not in N_Subexpr - or else not Is_Overloaded (N) - then + if Nkind (N) not in N_Subexpr or else not Is_Overloaded (N) then Mark_Use_Clauses (N); end if; @@ -6541,6 +6543,7 @@ package body Sem_Ch8 is function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id is Curr : Node_Id; + begin -- Loop through the Prev_Use_Clause chain @@ -8206,7 +8209,6 @@ package body Sem_Ch8 is ---------------------- procedure Mark_Use_Clauses (Id : Node_Or_Entity_Id) is - procedure Mark_Parameters (Call : Entity_Id); -- Perform use_type_clause marking for all parameters in a subprogram -- or operator call. @@ -8249,8 +8251,8 @@ package body Sem_Ch8 is Curr : Node_Id; begin - -- Ignore cases where the scope of the type is not a package - -- (e.g. Standard_Standard). + -- Ignore cases where the scope of the type is not a package (e.g. + -- Standard_Standard). if Ekind (Pak) /= E_Package then return; @@ -8258,10 +8260,10 @@ package body Sem_Ch8 is Curr := Current_Use_Clause (Pak); while Present (Curr) - and then not Is_Effective_Use_Clause (Curr) + and then not Is_Effective_Use_Clause (Curr) loop - -- We need to mark the previous use clauses as effective, but each - -- use clause may in turn render other use_package_clauses + -- We need to mark the previous use clauses as effective, but + -- each use clause may in turn render other use_package_clauses -- effective. Additionally, it is possible to have a parent -- package renamed as a child of itself so we must check the -- prefix entity is not the same as the package we are marking. @@ -8312,6 +8314,7 @@ package body Sem_Ch8 is -- for ignoring previous errors. Mark_Use_Package (Scope (Base_Type (Etype (E)))); + if Nkind (E) in N_Op and then Present (Entity (E)) and then Present (Scope (Entity (E))) @@ -8346,7 +8349,7 @@ package body Sem_Ch8 is -- Use clauses in and of themselves do not count as a "use" of a -- package. - if Nkind_In (Parent (Id), N_Use_Type_Clause, N_Use_Package_Clause) then + if Nkind_In (Parent (Id), N_Use_Package_Clause, N_Use_Type_Clause) then return; end if; @@ -8368,8 +8371,8 @@ package body Sem_Ch8 is -- Mark primitives elsif (Ekind (Id) in Overloadable_Kind - or else Ekind_In - (Ekind (Id), E_Generic_Function, E_Generic_Procedure)) + or else Ekind_In (Id, E_Generic_Function, + E_Generic_Procedure)) and then (Is_Potentially_Use_Visible (Id) or else Is_Intrinsic_Subprogram (Id)) then @@ -8388,7 +8391,7 @@ package body Sem_Ch8 is -- expression. if Nkind (Id) in N_Binary_Op - and then not (Nkind (Left_Opnd (Id)) in N_Op) + and then not (Nkind (Left_Opnd (Id)) in N_Op) then Mark_Use_Type (Left_Opnd (Id)); end if; @@ -8896,8 +8899,9 @@ package body Sem_Ch8 is and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard and then Handle_Use then - Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause, - Force_Installation => True); + Install_Use_Clauses + (Scope_Stack.Table (SS_Last).First_Use_Clause, + Force_Installation => True); end if; end Restore_Scope_Stack; @@ -9020,7 +9024,6 @@ package body Sem_Ch8 is ----------------------------- procedure Update_Use_Clause_Chain is - procedure Update_Chain_In_Scope (Level : Int); -- Iterate through one level in the scope stack verifying each use-type -- clause within said level is used then reset the Current_Use_Clause @@ -9058,7 +9061,6 @@ package body Sem_Ch8 is and then not Is_Effective_Use_Clause (Curr) and then not In_Instance then - -- We are dealing with a potentially unused use_package_clause if Nkind (Curr) = N_Use_Package_Clause then @@ -9068,21 +9070,24 @@ package body Sem_Ch8 is if not (Present (Associated_Node (N)) and then Present - (Current_Use_Clause (Associated_Node (N))) + (Current_Use_Clause + (Associated_Node (N))) and then Is_Effective_Use_Clause - (Current_Use_Clause (Associated_Node (N)))) + (Current_Use_Clause + (Associated_Node (N)))) then Error_Msg_Node_1 := Entity (N); - Error_Msg_NE ("use clause for package &? has no effect", - Curr, Entity (N)); + Error_Msg_NE + ("use clause for package &? has no effect", + Curr, Entity (N)); end if; -- We are dealing with an unused use_type_clause else Error_Msg_Node_1 := Etype (N); - Error_Msg_NE ("use clause for }? has no effect", - Curr, Etype (N)); + Error_Msg_NE + ("use clause for }? has no effect", Curr, Etype (N)); end if; end if; @@ -9123,7 +9128,6 @@ package body Sem_Ch8 is Pack_Name : Entity_Id := Empty; Force : Boolean := False) is - procedure Note_Redundant_Use (Clause : Node_Id); -- Mark the name in a use clause as redundant if the corresponding -- entity is already use-visible. Emit a warning if the use clause comes @@ -9134,8 +9138,8 @@ package body Sem_Ch8 is ------------------------ procedure Note_Redundant_Use (Clause : Node_Id) is - Pack_Name : constant Entity_Id := Entity (Clause); Decl : constant Node_Id := Parent (Clause); + Pack_Name : constant Entity_Id := Entity (Clause); Cur_Use : Node_Id := Current_Use_Clause (Pack_Name); Prev_Use : Node_Id := Empty; @@ -9191,10 +9195,11 @@ package body Sem_Ch8 is elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then declare Cur_Unit : constant Unit_Number_Type := - Get_Source_Unit (Cur_Use); + Get_Source_Unit (Cur_Use); New_Unit : constant Unit_Number_Type := - Get_Source_Unit (Clause); - Scop : Entity_Id; + Get_Source_Unit (Clause); + + Scop : Entity_Id; begin if Cur_Unit = New_Unit then @@ -9216,8 +9221,8 @@ package body Sem_Ch8 is Redundant := Clause; Prev_Use := Cur_Use; - -- Most common case: redundant clause in body, - -- original clause in spec. Current scope is spec entity. + -- Most common case: redundant clause in body, original + -- clause in spec. Current scope is spec entity. elsif Current_Scope = Cunit_Entity (Current_Sem_Unit) then Redundant := Cur_Use; @@ -9287,8 +9292,8 @@ package body Sem_Ch8 is -- visible part of the child, and no warning should be emitted. if Nkind (Parent (Decl)) = N_Package_Specification - and then - List_Containing (Decl) = Private_Declarations (Parent (Decl)) + and then List_Containing (Decl) = + Private_Declarations (Parent (Decl)) then declare Par : constant Entity_Id := Defining_Entity (Parent (Decl)); @@ -9299,16 +9304,16 @@ package body Sem_Ch8 is if Is_Compilation_Unit (Par) and then Par /= Cunit_Entity (Current_Sem_Unit) and then Parent (Cur_Use) = Spec - and then - List_Containing (Cur_Use) = Visible_Declarations (Spec) + and then List_Containing (Cur_Use) = + Visible_Declarations (Spec) then return; end if; end; end if; - -- Finally, if the current use clause is in the context then - -- the clause is redundant when it is nested within the unit. + -- Finally, if the current use clause is in the context then the + -- clause is redundant when it is nested within the unit. elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit @@ -9320,6 +9325,7 @@ package body Sem_Ch8 is end if; if Present (Redundant) and then Parent (Redundant) /= Prev_Use then + -- Make sure we are looking at most-descendant use_package_clause -- by traversing the chain with Find_Most_Prev and then verifying -- there is no scope manipulation via Most_Descendant_Use_Clause. @@ -9328,7 +9334,7 @@ package body Sem_Ch8 is and then (Nkind (Parent (Prev_Use)) /= N_Compilation_Unit or else Most_Descendant_Use_Clause - (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use) + (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use) then Prev_Use := Find_Most_Prev (Prev_Use); end if; @@ -9342,12 +9348,12 @@ package body Sem_Ch8 is -- Local variables + Current_Instance : Entity_Id := Empty; Id : Entity_Id; + P : Entity_Id; Prev : Entity_Id; - Current_Instance : Entity_Id := Empty; - Real_P : Entity_Id; Private_With_OK : Boolean := False; - P : Entity_Id; + Real_P : Entity_Id; -- Start of processing for Use_One_Package @@ -9388,9 +9394,11 @@ package body Sem_Ch8 is if In_Use (P) then Note_Redundant_Use (Pack_Name); + if not Force then Set_Current_Use_Clause (P, N); end if; + return; -- Warn about detected redundant clauses @@ -9401,6 +9409,7 @@ package body Sem_Ch8 is ("& is already use-visible within itself?r?", Pack_Name, P); end if; + return; end if; @@ -9432,10 +9441,9 @@ package body Sem_Ch8 is end if; end if; - -- If unit is a package renaming, indicate that the renamed - -- package is also in use (the flags on both entities must - -- remain consistent, and a subsequent use of either of them - -- should be recognized as redundant). + -- If unit is a package renaming, indicate that the renamed package is + -- also in use (the flags on both entities must remain consistent, and a + -- subsequent use of either of them should be recognized as redundant). if Present (Renamed_Object (P)) then Set_In_Use (Renamed_Object (P)); @@ -9600,13 +9608,10 @@ package body Sem_Ch8 is ------------------ procedure Use_One_Type - (Id : Node_Id; Installed : Boolean := False; Force : Boolean := False) + (Id : Node_Id; + Installed : Boolean := False; + Force : Boolean := False) is - Elmt : Elmt_Id; - Is_Known_Used : Boolean; - Op_List : Elist_Id; - T : Entity_Id; - function Spec_Reloaded_For_Body return Boolean; -- Determine whether the compilation unit is a package body and the use -- type clause is in the spec of the same package. Even though the spec @@ -9635,9 +9640,9 @@ package body Sem_Ch8 is return Nkind (Spec) = N_Package_Specification - and then - In_Same_Source_Unit (Corresponding_Body (Parent (Spec)), - Cunit_Entity (Current_Sem_Unit)); + and then In_Same_Source_Unit + (Corresponding_Body (Parent (Spec)), + Cunit_Entity (Current_Sem_Unit)); end; end if; @@ -9649,9 +9654,6 @@ package body Sem_Ch8 is ------------------------------- procedure Use_Class_Wide_Operations (Typ : Entity_Id) is - Scop : Entity_Id; - Ent : Entity_Id; - function Is_Class_Wide_Operation_Of (Op : Entity_Id; T : Entity_Id) return Boolean; @@ -9663,8 +9665,8 @@ package body Sem_Ch8 is --------------------------------- function Is_Class_Wide_Operation_Of - (Op : Entity_Id; - T : Entity_Id) return Boolean + (Op : Entity_Id; + T : Entity_Id) return Boolean is Formal : Entity_Id; @@ -9674,6 +9676,7 @@ package body Sem_Ch8 is if Etype (Formal) = Class_Wide_Type (T) then return True; end if; + Next_Formal (Formal); end loop; @@ -9684,6 +9687,11 @@ package body Sem_Ch8 is return False; end Is_Class_Wide_Operation_Of; + -- Local variables + + Ent : Entity_Id; + Scop : Entity_Id; + -- Start of processing for Use_Class_Wide_Operations begin @@ -9708,6 +9716,13 @@ package body Sem_Ch8 is end if; end Use_Class_Wide_Operations; + -- Local variables + + Elmt : Elmt_Id; + Is_Known_Used : Boolean; + Op_List : Elist_Id; + T : Entity_Id; + -- Start of processing for Use_One_Type begin @@ -9724,13 +9739,13 @@ package body Sem_Ch8 is -- in use or the entity is declared in the current package, thus -- use-visible. - Is_Known_Used := (In_Use (T) - and then ((Present (Current_Use_Clause (T)) - and then All_Present - (Current_Use_Clause (T))) - or else not All_Present (Parent (Id)))) - or else In_Use (Scope (T)) - or else Scope (T) = Current_Scope; + Is_Known_Used := + (In_Use (T) + and then ((Present (Current_Use_Clause (T)) + and then All_Present (Current_Use_Clause (T))) + or else not All_Present (Parent (Id)))) + or else In_Use (Scope (T)) + or else Scope (T) = Current_Scope; Set_Redundant_Use (Id, Is_Known_Used or else Is_Potentially_Use_Visible (T)); @@ -9784,8 +9799,8 @@ package body Sem_Ch8 is Set_Current_Use_Clause (T, Parent (Id)); Set_In_Use (T); - -- If T is tagged, primitive operators on class-wide operands - -- are also available. + -- If T is tagged, primitive operators on class-wide operands are + -- also available. if Is_Tagged_Type (T) then Set_In_Use (Class_Wide_Type (T)); @@ -9862,8 +9877,8 @@ package body Sem_Ch8 is if Present (Current_Use_Clause (T)) then Use_Clause_Known : declare - Clause1 : constant Node_Id := Find_Most_Prev - (Current_Use_Clause (T)); + Clause1 : constant Node_Id := + Find_Most_Prev (Current_Use_Clause (T)); Clause2 : constant Node_Id := Parent (Id); Ent1 : Entity_Id; Ent2 : Entity_Id; @@ -9938,7 +9953,8 @@ package body Sem_Ch8 is else declare - S1, S2 : Entity_Id; + S1 : Entity_Id; + S2 : Entity_Id; begin S1 := Scope (Ent1); @@ -9986,8 +10002,8 @@ package body Sem_Ch8 is end if; end Use_Clause_Known; - -- Here if Current_Use_Clause is not set for T, another case - -- where we do not have the location information available. + -- Here if Current_Use_Clause is not set for T, another case where + -- we do not have the location information available. else Error_Msg_NE -- CODEFIX @@ -9998,8 +10014,8 @@ package body Sem_Ch8 is -- The package where T is declared is already used elsif In_Use (Scope (T)) then - Error_Msg_Sloc := Sloc (Find_Most_Prev - (Current_Use_Clause (Scope (T)))); + Error_Msg_Sloc := + Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T)))); Error_Msg_NE -- CODEFIX ("& is already use-visible through package use clause #??", Id, T); diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads index e87f5aafd51..bee5f49e874 100644 --- a/gcc/ada/sem_ch8.ads +++ b/gcc/ada/sem_ch8.ads @@ -53,17 +53,15 @@ package Sem_Ch8 is procedure Analyze_Package_Renaming (N : Node_Id); procedure Analyze_Subprogram_Renaming (N : Node_Id); - procedure Analyze_Use_Package (N : Node_Id; - Chain : Boolean := True); - -- Analyze a use package clause and control (through the Chain - -- parameter) whether to add N to the use clause chain for the name - -- denoted within use clause N in case we are reanalyzing a use clause - -- because of stack manipulation. - - procedure Analyze_Use_Type (N : Node_Id; - Chain : Boolean := True); - -- Similar to Analyze_Use_Package except the Chain parameter applies - -- to the type within N's subtype mark Current_Use_Clause. + procedure Analyze_Use_Package (N : Node_Id; Chain : Boolean := True); + -- Analyze a use package clause and control (through the Chain parameter) + -- whether to add N to the use clause chain for the name denoted within + -- use clause N in case we are reanalyzing a use clause because of stack + -- manipulation. + + procedure Analyze_Use_Type (N : Node_Id; Chain : Boolean := True); + -- Similar to Analyze_Use_Package except the Chain parameter applies to the + -- type within N's subtype mark Current_Use_Clause. procedure End_Scope; -- Called at end of scope. On exit from blocks and bodies (subprogram, diff --git a/gcc/ada/sem_spark.adb b/gcc/ada/sem_spark.adb index fa9c19927a4..5107d3bc5f4 100644 --- a/gcc/ada/sem_spark.adb +++ b/gcc/ada/sem_spark.adb @@ -5286,6 +5286,7 @@ package body Sem_SPARK is is begin case Nkind (N) is + -- Base identifier. Set permission to W or No depending on Mode. when N_Identifier @@ -5293,9 +5294,8 @@ package body Sem_SPARK is => declare P : constant Node_Id := Entity (N); - C : constant Perm_Tree_Access := - Get (Current_Perm_Env, Unique_Entity (P)); + Get (Current_Perm_Env, Unique_Entity (P)); begin -- The base tree can be RW (first move from this base path) or diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index 48061238659..7f4b7861e15 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -355,10 +355,10 @@ package body Sinput.L is T : Osint.File_Type) return Source_File_Index is FD : File_Descriptor; + Hi : Source_Ptr; + Lo : Source_Ptr; Src : Source_Buffer_Ptr; X : Source_File_Index; - Lo : Source_Ptr; - Hi : Source_Ptr; Preprocessing_Needed : Boolean := False; diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 725bb4c2867..63b124ab723 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -158,8 +158,8 @@ package body Targparm is Set_NUP : Set_NUP_Type := null) is FD : File_Descriptor; - Text : Source_Buffer_Ptr; Hi : Source_Ptr; + Text : Source_Buffer_Ptr; begin if Parameters_Obtained then @@ -173,11 +173,13 @@ package body Targparm is if Null_Source_Buffer_Ptr (Text) then Write_Line ("fatal error, run-time library not installed correctly"); + if FD = Null_FD then Write_Line ("cannot locate file system.ads"); else Write_Line ("no read access for file system.ads"); end if; + raise Unrecoverable_Error; end if; -- 2.30.2