From a2667f14a89bc5492f51ff0ee794ee75d8068f43 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 26 Oct 2015 12:51:46 +0100 Subject: [PATCH] [multiple changes] 2015-10-26 Bob Duff * s-fileio.adb (Fopen_Mode): Use "r+" for Out_File/Stream_IO, so the file won't be truncated on 'fopen', as required by AI95-00283-1. 2015-10-26 Bob Duff * gnat1drv.adb, prj.adb, sem_ch6.adb, s-regpat.adb, sem_prag.adb: Fix typos. * einfo.ads, restrict.ads: Minor comment fixes. * err_vars.ads, sem_util.adb, errout.ads: Code clean up. 2015-10-26 Ed Schonberg * sem_ch5.adb (Analyze_Assignment): Do not check that the Left-hand side is legal in an inlined body, check is done on the original template. 2015-10-26 Ed Schonberg * exp_util.ads, exp_util.adb (Find_Primitive_Operations): New subprogram to retrieve by name the possibly overloaded set of primitive operations of a type. * sem_ch4.adb (Try_Container_Indexing): Use Find_Primitive_Operations to handle overloaded indexing operations of a derived type. From-SVN: r229343 --- gcc/ada/ChangeLog | 28 ++++++++++++++++++++++++++++ gcc/ada/einfo.ads | 2 +- gcc/ada/err_vars.ads | 2 +- gcc/ada/errout.ads | 2 +- gcc/ada/exp_util.adb | 44 ++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/exp_util.ads | 7 +++++++ gcc/ada/gnat1drv.adb | 2 +- gcc/ada/prj.adb | 2 +- gcc/ada/restrict.ads | 2 +- gcc/ada/s-fileio.adb | 8 ++++---- gcc/ada/s-regpat.adb | 6 +++--- gcc/ada/sem_ch4.adb | 9 +++------ gcc/ada/sem_ch5.adb | 8 +++++++- gcc/ada/sem_ch6.adb | 2 +- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_util.adb | 2 +- 16 files changed, 105 insertions(+), 23 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 76f1356b279..8b146ae655e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2015-10-26 Bob Duff + + * s-fileio.adb (Fopen_Mode): Use "r+" for Out_File/Stream_IO, + so the file won't be truncated on 'fopen', as required by + AI95-00283-1. + +2015-10-26 Bob Duff + + * gnat1drv.adb, prj.adb, sem_ch6.adb, s-regpat.adb, + sem_prag.adb: Fix typos. + * einfo.ads, restrict.ads: Minor comment fixes. + * err_vars.ads, sem_util.adb, errout.ads: Code clean up. + +2015-10-26 Ed Schonberg + + * sem_ch5.adb (Analyze_Assignment): Do not check that the + Left-hand side is legal in an inlined body, check is done on + the original template. + +2015-10-26 Ed Schonberg + + * exp_util.ads, exp_util.adb (Find_Primitive_Operations): New + subprogram to retrieve by name the possibly overloaded set of + primitive operations of a type. + * sem_ch4.adb (Try_Container_Indexing): Use + Find_Primitive_Operations to handle overloaded indexing operations + of a derived type. + 2015-10-26 Arnaud Charlet * osint-c.ads: Minor comment update. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e74a0a7ffc2..22e42dd6de1 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1566,7 +1566,7 @@ package Einfo is -- delayed and is one of the characteristics that may be inherited by -- types derived from this type if not overridden. If this flag is set, -- then types derived from this type have May_Inherit_Delayed_Rep_Aspects --- set, signalling that Freeze.Inhert_Delayed_Rep_Aspects must be called +-- set, signalling that Freeze.Inherit_Delayed_Rep_Aspects must be called -- at the freeze point of the derived type. -- Has_Discriminants (Flag5) diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index c9beb0ccc30..0c2fb6f7c92 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.ads @@ -54,7 +54,7 @@ package Err_Vars is -- variables are not reset by calls to the error message routines, so the -- caller is responsible for resetting the default behavior after use. - Error_Msg_Qual_Level : Int := 0; + Error_Msg_Qual_Level : Nat := 0; -- Number of levels of qualification required for type name (see the -- description of the } insertion character. Note that this value does -- not get reset by any Error_Msg call, so the caller is responsible diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index be0c936d298..4540c9380ae 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -474,7 +474,7 @@ package Errout is Error_Msg_Node_2 : Node_Id renames Err_Vars.Error_Msg_Node_2; -- Node_Id values for & insertion characters in message - Error_Msg_Qual_Level : Int renames Err_Vars.Error_Msg_Qual_Level; + Error_Msg_Qual_Level : Nat renames Err_Vars.Error_Msg_Qual_Level; -- Number of levels of qualification required for type name (see the -- description of the } insertion character). Note that this value does -- not get reset by any Error_Msg call, so the caller is responsible diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 790556fdd25..73fb9b85dea 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2707,6 +2707,50 @@ package body Exp_Util is end if; end Find_Optional_Prim_Op; + ------------------------------- + -- Find_Primitive_Operations -- + ------------------------------- + + function Find_Primitive_Operations + (T : Entity_Id; + Name : Name_Id) return Node_Id + is + Prim_Elmt : Elmt_Id; + Prim_Id : Entity_Id; + Ref : Node_Id; + Typ : Entity_Id := T; + + begin + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Typ := Underlying_Type (Typ); + + Ref := Empty; + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim_Id := Node (Prim_Elmt); + if Chars (Prim_Id) = Name then + + -- If this is the first primitive operation found, + -- create a reference to it. + + if No (Ref) then + Ref := New_Occurrence_Of (Prim_Id, Sloc (T)); + + -- Otherwise, add interpretation to existing reference + + else + Add_One_Interp (Ref, Prim_Id, Etype (Prim_Id)); + end if; + end if; + Next_Elmt (Prim_Elmt); + end loop; + + return Ref; + end Find_Primitive_Operations; + ------------------ -- Find_Prim_Op -- ------------------ diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 913c71b97c5..b6cf41d3b59 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -467,6 +467,13 @@ package Exp_Util is -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, -- return the record component containing the tag of Iface. + function Find_Primitive_Operations + (T : Entity_Id; + Name : Name_Id) return Node_Id; + -- Return a reference to a primitive operation with given name. If + -- operation is overloaded, the node carries the corresponding set + -- of overloaded interpretations. + function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; -- Find the first primitive operation of a tagged type T with name Name. -- This function allows the use of a primitive operation which is not diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 727e90a4401..cd89cb570fd 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -1036,7 +1036,7 @@ begin Original_Operating_Mode := Operating_Mode; Frontend; - -- Exit with errors if the main source could not be parsed. + -- Exit with errors if the main source could not be parsed if Sinput.Main_Source_File = No_Source_File then Errout.Finalize (Last_Call => True); diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index d1c0b169f06..ac5b445cdaf 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -143,7 +143,7 @@ package body Prj is while Last + S'Length > To'Last loop declare - New_Buffer : constant String_Access := + New_Buffer : constant String_Access := new String (1 .. 2 * To'Length); begin New_Buffer (1 .. Last) := To (1 .. Last); diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 48a531d0350..c34113a7da7 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -546,7 +546,7 @@ package Restrict is function Cunit_Boolean_Restrictions_Save return Save_Cunit_Boolean_Restrictions; -- This function saves the compilation unit restriction settings, leaving - -- then unchanged. This is used e.g. at the start of processing a context + -- them unchanged. This is used e.g. at the start of processing a context -- clause, so that the main unit restrictions can be restored after all -- the with'ed units have been processed. diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 1d8882e3ad8..e9d54f84f47 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -433,8 +433,8 @@ package body System.File_IO is -- OPEN CREATE -- Append_File "r+" "w+" -- In_File "r" "w+" - -- Out_File (Direct_IO) "r+" "w" - -- Out_File (all others) "w" "w" + -- Out_File (Direct_IO, Stream_IO) "r+" "w" + -- Out_File (others) "w" "w" -- Inout_File "r+" "w+" -- Note: we do not use "a" or "a+" for Append_File, since this would not @@ -479,7 +479,7 @@ package body System.File_IO is end if; when Out_File => - if Amethod = 'D' and then not Creat then + if Amethod in 'D' | 'S' and then not Creat then Fopstr (1) := 'r'; Fopstr (2) := '+'; Fptr := 3; diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb index d5ef0229e47..4127ec99523 100644 --- a/gcc/ada/s-regpat.adb +++ b/gcc/ada/s-regpat.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1999-2014, AdaCore -- +-- Copyright (C) 1999-2015, AdaCore -- -- -- -- 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- -- @@ -413,7 +413,7 @@ package body System.Regpat is Capturing : Boolean; Flags : out Expression_Flags; IP : out Pointer); - -- Parse regular expression, i.e. main body or parenthesized thing + -- Parse regular expression, i.e. main body or parenthesized thing. -- Caller must absorb opening parenthesis. Capturing should be set to -- True when we have an open parenthesis from which we want the user -- to extra text. @@ -422,7 +422,7 @@ package body System.Regpat is (Flags : out Expression_Flags; First : Boolean; IP : out Pointer); - -- Implements the concatenation operator and handles '|' + -- Implements the concatenation operator and handles '|'. -- First should be true if this is the first item of the alternative. procedure Parse_Piece diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9928c3b0cfb..3b55ea3971f 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7215,20 +7215,17 @@ package body Sem_Ch4 is -- However, Reference is also a primitive operation of the type, and -- the inherited operation has a different signature. We retrieve the - -- right one from the list of primitive operations of the derived type. + -- right ones (the function may be overloaded) from the list of + -- primitive operations of the derived type. -- Note that predefined containers are typically all derived from one -- of the Controlled types. The code below is motivated by containers -- that are derived from other types with a Reference aspect. - -- Additional machinery may be needed for types that have several user- - -- defined Reference operations with different signatures ??? - elsif Is_Derived_Type (C_Type) and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix) then - Func := Find_Prim_Op (C_Type, Chars (Func_Name)); - Func_Name := New_Occurrence_Of (Func, Loc); + Func_Name := Find_Primitive_Operations (C_Type, Chars (Func_Name)); end if; Assoc := New_List (Relocate_Node (Prefix)); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 24e641ebfea..3e791799c2a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -394,7 +394,13 @@ package body Sem_Ch5 is -- Cases where Lhs is not a variable - if not Is_Variable (Lhs) then + -- Cases where Lhs is not a variable. In an instance or an inlined body + -- no need for further check because assignment was legal in template. + + if In_Inlined_Body then + null; + + elsif not Is_Variable (Lhs) then -- Ada 2005 (AI-327): Check assignment to the attribute Priority of a -- protected object. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d36cf850b4b..97d85200587 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4833,7 +4833,7 @@ package body Sem_Ch6 is else declare - T : constant Entity_Id := Find_Dispatching_Type (New_Id); + T : constant Entity_Id := Find_Dispatching_Type (New_Id); begin if Is_Protected_Type (Corresponding_Concurrent_Type (T)) then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 779e91e0d16..cd0a392c7fc 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4635,7 +4635,7 @@ package body Sem_Prag is P : constant Node_Id := Parent (N); begin - -- Must be at in subprogram body + -- Must be in subprogram body if Nkind (P) /= N_Subprogram_Body then Error_Pragma ("% pragma allowed only in subprogram"); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 464619a2061..cf7c57e3c01 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -19690,7 +19690,7 @@ package body Sem_Util is Expec_Scope := Expec_Type; Found_Scope := Found_Type; - for Levels in Int range 0 .. 3 loop + for Levels in Nat range 0 .. 3 loop if Chars (Expec_Scope) /= Chars (Found_Scope) then Error_Msg_Qual_Level := Levels; exit; -- 2.30.2