From: Arnaud Charlet Date: Fri, 8 Sep 2017 10:05:18 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f63adaa7a4ae18c7b0dc420f9e298f5b0746da6f;p=gcc.git [multiple changes] 2017-09-08 Yannick Moy * sem_prag.adb: Use System.Case_Util.To_Lower to simplify code. 2017-09-08 Arnaud Charlet * opt.ads (Include_Subprogram_In_Messages): New variable. * errout.ads (Current_Subprogram_Ptr): New variable. * errout.adb (Error_Msg): Prepend current subprogram info in messages if Include_Subprogram_In_Messages is set. * sem_util.adb (elab code): Initialize Current_Subprogram_Ptr to Current_Subprogram. * gnat1drv.adb (Adjust_Global_Switches): Set Include_Subprogram_In_Messages when -gnatdJ is set. * debug.adb: Document and reserve -gnatdJ. 2017-09-08 Georges-Axel Jaloyan * g-dynhta.adb, g-dynhta.ads (Get_First_Key, Get_Next_Key): New functions to iterate over simple hastables. (Load_Factor_HTable): Remove obsolete and inefficient implementation. 2017-09-08 Javier Miranda * exp_ch6.adb (Unqual_BIP_Function_Call): Adding missing checks on the presence of Entity() before checking the entity attributes. 2017-09-08 Eric Botcazou * sem_ch6.adb (Analyze_Expression_Function): Reorder some statements, use local variable and remove unnecessary processing. From-SVN: r251880 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c3c48a535e8..3e030fe752b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2017-09-08 Yannick Moy + + * sem_prag.adb: Use System.Case_Util.To_Lower to simplify code. + +2017-09-08 Arnaud Charlet + + * opt.ads (Include_Subprogram_In_Messages): New variable. + * errout.ads (Current_Subprogram_Ptr): New variable. + * errout.adb (Error_Msg): Prepend current subprogram info + in messages if Include_Subprogram_In_Messages is set. + * sem_util.adb (elab code): Initialize Current_Subprogram_Ptr to + Current_Subprogram. + * gnat1drv.adb (Adjust_Global_Switches): Set + Include_Subprogram_In_Messages when -gnatdJ is set. + * debug.adb: Document and reserve -gnatdJ. + +2017-09-08 Georges-Axel Jaloyan + + * g-dynhta.adb, g-dynhta.ads (Get_First_Key, Get_Next_Key): New + functions to iterate over simple hastables. + (Load_Factor_HTable): Remove obsolete and inefficient implementation. + +2017-09-08 Javier Miranda + + * exp_ch6.adb (Unqual_BIP_Function_Call): Adding + missing checks on the presence of Entity() before checking the + entity attributes. + +2017-09-08 Eric Botcazou + + * sem_ch6.adb (Analyze_Expression_Function): Reorder some + statements, use local variable and remove unnecessary processing. + 2017-09-08 Javier Miranda * exp_ch6.ads (Make_Build_In_Place_Iface_Call_In_Allocator): New diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index f5a7e25e339..c45a1883ce2 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -73,7 +73,7 @@ package body Debug is -- dG Generate all warnings including those normally suppressed -- dH Hold (kill) call to gigi -- dI Inhibit internal name numbering in gnatG listing - -- dJ + -- dJ Prepend subprogram name in messages -- dK Kill all error messages -- dL Output trace information on elaboration checking -- dM Assume all variables are modified (no current values) @@ -400,6 +400,11 @@ package body Debug is -- is used in the fixed bugs run to minimize system and version -- dependency in filed -gnatD or -gnatG output. + -- dJ Prepend the name of the enclosing subprogram in compiler messages + -- (errors, warnings, style checks). This is useful in particular to + -- integrate compiler warnings in static analysis tools such as + -- CodePeer. + -- dK Kill all error messages. This debug flag suppresses the output -- of all error messages. It is used in regression tests where the -- error messages are target dependent and irrelevant. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index a04df945be8..664d36e0842 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -310,6 +310,8 @@ package body Errout is -- Original location of Flag_Location (i.e. location in original -- template in instantiation case, otherwise unchanged). + Entity : Bounded_String; + begin -- Return if all errors are to be ignored @@ -336,6 +338,18 @@ package body Errout is Prescan_Message (Msg); Orig_Loc := Original_Location (Flag_Location); + if Include_Subprogram_In_Messages then + declare + Ent : constant Entity_Id := Current_Subprogram_Ptr.all; + begin + if Present (Ent) then + Append_Unqualified_Decoded (Entity, Chars (Ent)); + else + Append (Entity, "unknown subprogram"); + end if; + end; + end if; + -- If the current location is in an instantiation, the issue arises of -- whether to post the message on the template or the instantiation. @@ -405,7 +419,14 @@ package body Errout is -- Error_Msg_Internal to place the message in the requested location. if Instantiation (Sindex) = No_Location then - Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False); + if Include_Subprogram_In_Messages then + Append (Entity, ": "); + Append (Entity, Msg); + Error_Msg_Internal (+Entity, Flag_Location, Flag_Location, False); + else + Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False); + end if; + return; end if; @@ -555,8 +576,15 @@ package body Errout is -- Here we output the original message on the outer instantiation - Error_Msg_Internal - (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + if Include_Subprogram_In_Messages then + Append (Entity, ": "); + Append (Entity, Msg); + Error_Msg_Internal + (+Entity, Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + else + Error_Msg_Internal + (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + end if; end; end Error_Msg; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index a8e4d6c15af..ad33673cdff 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -68,6 +68,11 @@ package Errout is -- error message tag. The -gnatw.d switch sets this flag True, -gnatw.D -- sets this flag False. + type Current_Subprogram_Type is access function return Entity_Id; + Current_Subprogram_Ptr : Current_Subprogram_Type := null; + -- Indirect call to Sem_Util.Current_Subprogram to break circular + -- dependency with the static elaboration model. + ----------------------------------- -- Suppression of Error Messages -- ----------------------------------- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index a36e51f7785..d04bbb1f075 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -9100,6 +9100,7 @@ package body Exp_Ch6 is -- Recurse on object renamings elsif Nkind (Expr) = N_Identifier + and then Present (Entity (Expr)) and then Ekind_In (Entity (Expr), E_Constant, E_Variable) and then Nkind (Parent (Entity (Expr))) = N_Object_Renaming_Declaration @@ -9112,6 +9113,7 @@ package body Exp_Ch6 is elsif not On_Object_Declaration and then Nkind (Expr) = N_Identifier + and then Present (Entity (Expr)) and then Ekind_In (Entity (Expr), E_Constant, E_Variable) and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration and then Present (Expression (Parent (Entity (Expr)))) @@ -9125,6 +9127,7 @@ package body Exp_Ch6 is elsif Nkind (Expr) = N_Function_Call and then Nkind (Name (Expr)) in N_Has_Entity + and then Present (Entity (Name (Expr))) and then RTU_Loaded (Ada_Tags) and then RTE_Available (RE_Displace) and then Is_RTE (Entity (Name (Expr)), RE_Displace) diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index c60f75a71f9..dbb9d3ee3ef 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -324,7 +324,7 @@ package body Exp_Prag is -- Discriminants of the enclosing protected object may be referenced -- in the expression of a precondition of a protected operation. -- In the body of the operation these references must be replaced by - -- the discriminal created for them, which area renamings of the + -- the discriminal created for them, which are renamings of the -- discriminants of the object that is the target of the operation. -- This replacement is done by visibility when the references appear -- in the subprogram body, but in the case of a condition which appears diff --git a/gcc/ada/g-dynhta.adb b/gcc/ada/g-dynhta.adb index 10931cc7d25..05ef90183d3 100644 --- a/gcc/ada/g-dynhta.adb +++ b/gcc/ada/g-dynhta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2016, AdaCore -- +-- Copyright (C) 2002-2017, 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- -- @@ -256,6 +256,20 @@ package body GNAT.Dynamic_HTables is end if; end Get_First; + ------------------- + -- Get_First_Key -- + ------------------- + + function Get_First_Key (T : Instance) return access constant Key is + Tmp : aliased constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); + begin + if Tmp = null then + return null; + else + return Tmp.all.K'Access; + end if; + end Get_First_Key; + ------------- -- Get_Key -- ------------- @@ -279,6 +293,20 @@ package body GNAT.Dynamic_HTables is end if; end Get_Next; + ------------------ + -- Get_Next_Key -- + ------------------ + + function Get_Next_Key (T : Instance) return access constant Key is + Tmp : aliased constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); + begin + if Tmp = null then + return null; + else + return Tmp.all.K'Access; + end if; + end Get_Next_Key; + ---------- -- Next -- ---------- @@ -347,364 +375,4 @@ package body GNAT.Dynamic_HTables is end Simple_HTable; - ------------------------ - -- Load_Factor_HTable -- - ------------------------ - - package body Load_Factor_HTable is - - Min_Size_Increase : constant := 5; - -- The minimum increase expressed as number of buckets. This value is - -- used to determine the new size of small tables and/or small growth - -- percentages. - - procedure Attach - (Elmt : not null Element_Ptr; - Chain : not null Element_Ptr); - -- Prepend an element to a bucket chain. Elmt is inserted after the - -- dummy head of Chain. - - function Create_Buckets (Size : Positive) return Buckets_Array_Ptr; - -- Allocate and initialize a new set of buckets. The buckets are created - -- in the range Range_Type'First .. Range_Type'First + Size - 1. - - procedure Detach (Elmt : not null Element_Ptr); - -- Remove an element from an arbitrary bucket chain - - function Find - (Key : Key_Type; - Chain : not null Element_Ptr) return Element_Ptr; - -- Try to locate the element which contains a particular key within a - -- bucket chain. If no such element exists, return No_Element. - - procedure Free is - new Ada.Unchecked_Deallocation (Buckets_Array, Buckets_Array_Ptr); - - procedure Free is - new Ada.Unchecked_Deallocation (Element, Element_Ptr); - - function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean; - -- Determine whether a bucket chain contains only one element, namely - -- the dummy head. - - ------------ - -- Attach -- - ------------ - - procedure Attach - (Elmt : not null Element_Ptr; - Chain : not null Element_Ptr) - is - begin - Chain.Next.Prev := Elmt; - Elmt.Next := Chain.Next; - Chain.Next := Elmt; - Elmt.Prev := Chain; - end Attach; - - -------------------- - -- Create_Buckets -- - -------------------- - - function Create_Buckets (Size : Positive) return Buckets_Array_Ptr is - Low_Bound : constant Range_Type := Range_Type'First; - Buckets : Buckets_Array_Ptr; - - begin - Buckets := - new Buckets_Array (Low_Bound .. Low_Bound + Range_Type (Size) - 1); - - -- Ensure that the dummy head of each bucket chain points to itself - -- in both directions. - - for Index in Buckets'Range loop - declare - Bucket : Element renames Buckets (Index); - - begin - Bucket.Prev := Bucket'Unchecked_Access; - Bucket.Next := Bucket'Unchecked_Access; - end; - end loop; - - return Buckets; - end Create_Buckets; - - ------------------ - -- Current_Size -- - ------------------ - - function Current_Size (T : Table) return Positive is - begin - -- The table should have been properly initialized during object - -- elaboration. - - if T.Buckets = null then - raise Program_Error; - - -- The size of the table is determined by the number of buckets - - else - return T.Buckets'Length; - end if; - end Current_Size; - - ------------ - -- Detach -- - ------------ - - procedure Detach (Elmt : not null Element_Ptr) is - begin - if Elmt.Prev /= null and Elmt.Next /= null then - Elmt.Prev.Next := Elmt.Next; - Elmt.Next.Prev := Elmt.Prev; - Elmt.Prev := null; - Elmt.Next := null; - end if; - end Detach; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (T : in out Table) is - Bucket : Element_Ptr; - Elmt : Element_Ptr; - - begin - -- Inspect the buckets and deallocate bucket chains - - for Index in T.Buckets'Range loop - Bucket := T.Buckets (Index)'Unchecked_Access; - - -- The current bucket chain contains an element other than the - -- dummy head. - - while not Is_Empty_Chain (Bucket) loop - - -- Skip the dummy head, remove and deallocate the element - - Elmt := Bucket.Next; - Detach (Elmt); - Free (Elmt); - end loop; - end loop; - - -- Deallocate the buckets - - Free (T.Buckets); - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Key : Key_Type; - Chain : not null Element_Ptr) return Element_Ptr - is - Elmt : Element_Ptr; - - begin - -- Skip the dummy head, inspect the bucket chain for an element whose - -- key matches the requested key. Since each bucket chain is circular - -- the search must stop once the dummy head is encountered. - - Elmt := Chain.Next; - while Elmt /= Chain loop - if Equal (Elmt.Key, Key) then - return Elmt; - end if; - - Elmt := Elmt.Next; - end loop; - - return No_Element; - end Find; - - --------- - -- Get -- - --------- - - function Get (T : Table; Key : Key_Type) return Value_Type is - Bucket : Element_Ptr; - Elmt : Element_Ptr; - - begin - -- Obtain the bucket chain where the (key, value) pair should reside - -- by calculating the proper hash location. - - Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access; - - -- Try to find an element whose key matches the requested key - - Elmt := Find (Key, Bucket); - - -- The hash table does not contain a matching (key, value) pair - - if Elmt = No_Element then - return No_Value; - else - return Elmt.Val; - end if; - end Get; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (T : in out Table) is - begin - pragma Assert (T.Buckets = null); - - T.Buckets := Create_Buckets (Initial_Size); - T.Element_Count := 0; - end Initialize; - - -------------------- - -- Is_Empty_Chain -- - -------------------- - - function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean is - begin - return Chain.Next = Chain and Chain.Prev = Chain; - end Is_Empty_Chain; - - ------------ - -- Remove -- - ------------ - - procedure Remove (T : in out Table; Key : Key_Type) is - Bucket : Element_Ptr; - Elmt : Element_Ptr; - - begin - -- Obtain the bucket chain where the (key, value) pair should reside - -- by calculating the proper hash location. - - Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access; - - -- Try to find an element whose key matches the requested key - - Elmt := Find (Key, Bucket); - - -- Remove and deallocate the (key, value) pair - - if Elmt /= No_Element then - Detach (Elmt); - Free (Elmt); - end if; - end Remove; - - --------- - -- Set -- - --------- - - procedure Set - (T : in out Table; - Key : Key_Type; - Val : Value_Type) - is - Curr_Size : constant Positive := Current_Size (T); - - procedure Grow; - -- Grow the table to a new size according to the desired percentage - -- and relocate all existing elements to the new buckets. - - ---------- - -- Grow -- - ---------- - - procedure Grow is - Buckets : Buckets_Array_Ptr; - Elmt : Element_Ptr; - Hash_Loc : Range_Type; - Old_Bucket : Element_Ptr; - Old_Buckets : Buckets_Array_Ptr := T.Buckets; - Size : Positive; - - begin - -- Calculate the new size and allocate a new set of buckets. Note - -- that a table with a small size or a small growth percentage may - -- not always grow (for example, 10 buckets and 3% increase). In - -- that case, enforce a minimum increase. - - Size := - Positive'Max (Curr_Size * ((100 + Growth_Percentage) / 100), - Min_Size_Increase); - Buckets := Create_Buckets (Size); - - -- Inspect the old buckets and transfer all elements by rehashing - -- all (key, value) pairs in the new buckets. - - for Index in Old_Buckets'Range loop - Old_Bucket := Old_Buckets (Index)'Unchecked_Access; - - -- The current bucket chain contains an element other than the - -- dummy head. - - while not Is_Empty_Chain (Old_Bucket) loop - - -- Skip the dummy head and find the new hash location - - Elmt := Old_Bucket.Next; - Hash_Loc := Hash (Elmt.Key, Size); - - -- Remove the element from the old buckets and insert it - -- into the new buckets. Note that there is no need to check - -- for duplicates because the hash table did not have any to - -- begin with. - - Detach (Elmt); - Attach - (Elmt => Elmt, - Chain => Buckets (Hash_Loc)'Unchecked_Access); - end loop; - end loop; - - -- Associate the new buckets with the table and reclaim the - -- storage occupied by the old buckets. - - T.Buckets := Buckets; - - Free (Old_Buckets); - end Grow; - - -- Local variables - - subtype LLF is Long_Long_Float; - - Count : Natural renames T.Element_Count; - Bucket : Element_Ptr; - Hash_Loc : Range_Type; - - -- Start of processing for Set - - begin - -- Find the bucket where the (key, value) pair should be inserted by - -- computing the proper hash location. - - Hash_Loc := Hash (Key, Curr_Size); - Bucket := T.Buckets (Hash_Loc)'Unchecked_Access; - - -- Ensure that the key is not already present in the bucket in order - -- to avoid duplicates. - - if Find (Key, Bucket) = No_Element then - Attach - (Elmt => new Element'(Key, Val, null, null), - Chain => Bucket); - Count := Count + 1; - - -- Multiple insertions may cause long bucket chains and decrease - -- the performance of basic operations. If this is the case, grow - -- the table and rehash all existing elements. - - if (LLF (Count) / LLF (Curr_Size)) > LLF (Load_Factor) then - Grow; - end if; - end if; - end Set; - end Load_Factor_HTable; - end GNAT.Dynamic_HTables; diff --git a/gcc/ada/g-dynhta.ads b/gcc/ada/g-dynhta.ads index d1dedae2a25..e80dfdfd172 100644 --- a/gcc/ada/g-dynhta.ads +++ b/gcc/ada/g-dynhta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2014, AdaCore -- +-- Copyright (C) 1995-2017, 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- -- @@ -48,8 +48,6 @@ -- GNAT.HTable to keep as much coherency as possible between these two -- related units. -private with Ada.Finalization; - package GNAT.Dynamic_HTables is ------------------- @@ -124,11 +122,11 @@ package GNAT.Dynamic_HTables is function Get_First (T : Instance) return Elmt_Ptr; -- Returns Null_Ptr if the Htable is empty, otherwise returns one - -- non specified element. There is no guarantee that 2 calls to this + -- unspecified element. There is no guarantee that 2 calls to this -- function will return the same element. function Get_Next (T : Instance) return Elmt_Ptr; - -- Returns a non-specified element that has not been returned by the + -- Returns an unspecified element that has not been returned by the -- same function since the last call to Get_First or Null_Ptr if -- there is no such element or Get_First has never been called. If -- there is no call to 'Set' in between Get_Next calls, all the @@ -189,12 +187,18 @@ package GNAT.Dynamic_HTables is function Get_First (T : Instance) return Element; -- Returns No_Element if the Htable is empty, otherwise returns one - -- non specified element. There is no guarantee that two calls to this + -- unspecified element. There is no guarantee that two calls to this -- function will return the same element, if the Htable has been -- modified between the two calls. + function Get_First_Key (T : Instance) return access constant Key; + -- Returns Null if the Htable is empty, otherwise returns one + -- unspecified key. There is no guarantee that two calls to this + -- function will return the same key, if the Htable has been modified + -- between the two calls. + function Get_Next (T : Instance) return Element; - -- Returns a non-specified element that has not been returned by the + -- Returns an unspecified element that has not been returned by the -- same function since the last call to Get_First or No_Element if -- there is no such element. If there is no call to 'Set' in between -- Get_Next calls, all the elements of the Htable will be traversed. @@ -203,12 +207,18 @@ package GNAT.Dynamic_HTables is -- between a call to Get_First and subsequent consecutive calls to -- Get_Next, until one of these calls returns No_Element. + function Get_Next_Key (T : Instance) return access constant Key; + -- Same as Get_Next except that this returns an unspecified access + -- to constant key that has not been returned by either Get_First_Key + -- or this very same function (or null if there is none). The same + -- restrictions apply as Get_Next. + private type Element_Wrapper; type Elmt_Ptr is access all Element_Wrapper; type Element_Wrapper is record - K : Key; + K : aliased Key; E : Element; Next : Elmt_Ptr; end record; @@ -234,116 +244,4 @@ package GNAT.Dynamic_HTables is end Simple_HTable; - ------------------------ - -- Load_Factor_HTable -- - ------------------------ - - -- A simple hash table abstraction capable of growing once a threshold has - -- been exceeded. Collisions are resolved by chaining elements onto lists - -- hanging from individual buckets. This implementation does not make any - -- effort to minimize the number of necessary rehashes once the table has - -- been expanded, hence the term "simple". - - -- WARNING: This hash table implementation utilizes dynamic allocation. - -- Storage reclamation is performed by the hash table. - - -- WARNING: This hash table implementation is not thread-safe. To achieve - -- proper concurrency and synchronization, wrap an instance of a table in - -- a protected object. - - generic - type Range_Type is range <>; - -- The underlying range of the hash table. Note that this type must be - -- large enough to accommodate multiple expansions of the table. - - type Key_Type is private; - type Value_Type is private; - -- The types of the (key, value) pair stored in the hash table - - No_Value : Value_Type; - -- A predefined value denoting a non-existent value - - Initial_Size : Positive; - -- The starting size of the hash table. The hash table must contain at - -- least one bucket. - - Growth_Percentage : Positive; - -- The amount of increase expressed as a percentage. The hash table must - -- grow by at least 1%. To illustrate, a value of 100 will increase the - -- table by 100%, effectively doubling its size. - - Load_Factor : Float; - -- The ratio of the elements stored within the hash table divided by the - -- current size of the table. This value acts as the growth threshold. - -- If exceeded, the hash table is expanded by Growth_Percentage. - - with function Equal - (Left : Key_Type; - Right : Key_Type) return Boolean; - - with function Hash - (Key : Key_Type; - Size : Positive) return Range_Type; - -- Parameter Size denotes the current size of the hash table - - package Load_Factor_HTable is - type Table is tagged limited private; - - function Current_Size (T : Table) return Positive; - -- Obtain the current size of the table - - function Get (T : Table; Key : Key_Type) return Value_Type; - -- Obtain the value associated with a key. This routine returns No_Value - -- if the key is not present in the hash table. - - procedure Remove (T : in out Table; Key : Key_Type); - -- Remove the value associated with the given key. This routine has no - -- effect if the key is not present in the hash table. - - procedure Set - (T : in out Table; - Key : Key_Type; - Val : Value_Type); - -- Associate a value with a given key. This routine has no effect if the - -- the (key, value) pair is already present in the hash table. Note that - -- this action may cause the table to grow. - - private - -- The following types model a bucket chain. Note that the key is also - -- stored for rehashing purposes. - - type Element; - type Element_Ptr is access all Element; - type Element is record - Key : Key_Type; - Val : Value_Type; - Prev : Element_Ptr := null; - Next : Element_Ptr := null; - end record; - - No_Element : constant Element_Ptr := null; - - -- The following types model the buckets of the hash table. Each bucket - -- has a dummy head to facilitate insertion and deletion of elements. - - type Buckets_Array is array (Range_Type range <>) of aliased Element; - type Buckets_Array_Ptr is access all Buckets_Array; - - type Table is new Ada.Finalization.Limited_Controlled with record - Buckets : Buckets_Array_Ptr := null; - - Element_Count : Natural := 0; - -- The number of (key, value) pairs stored in the hash table - end record; - - procedure Finalize (T : in out Table); - -- Destroy the contents of a hash table by reclaiming all storage used - -- by buckets and their respective chains. - - procedure Initialize (T : in out Table); - -- Create a hash table with buckets within the range Range_Type'First .. - -- Range_Type'First + Initial_Size - 1. - - end Load_Factor_HTable; - end GNAT.Dynamic_HTables; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 8a974c9f0b9..e60d912a903 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -178,6 +178,13 @@ procedure Gnat1drv is Error_To_Warning := True; end if; + -- -gnatdJ sets Include_Subprogram_In_Messages, adding the related + -- subprogram as part of the error and warning messages. + + if Debug_Flag_JJ then + Include_Subprogram_In_Messages := True; + end if; + -- Disable CodePeer_Mode in Check_Syntax, since we need front-end -- expansion. diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index aef84edcfac..1c7c0a0e208 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -848,6 +848,10 @@ package Opt is -- cause implicit packing instead of generating an error message. Set by -- use of pragma Implicit_Packing. + Include_Subprogram_In_Messages : Boolean := False; + -- GNAT + -- Set True to include the enclosing subprogram in compiler messages. + Ineffective_Inline_Warnings : Boolean := False; -- GNAT -- Set True to activate warnings if front-end inlining (-gnatN) is not able diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 54b02e4fa6c..37459f80382 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -672,6 +672,15 @@ package body Sem_Ch6 is end if; Def_Id := Defining_Entity (N); + Set_Is_Inlined (Def_Id); + + -- Establish the linkages between the spec and the body. These are + -- used when the expression function acts as the prefix of attribute + -- 'Access in order to freeze the original expression which has been + -- moved to the generated body. + + Set_Corresponding_Body (N, Defining_Entity (New_Body)); + Set_Corresponding_Spec (New_Body, Def_Id); -- Within a generic pre-analyze the original expression for name -- capture. The body is also generated but plays no role in @@ -685,16 +694,6 @@ package body Sem_Ch6 is End_Scope; end if; - Set_Is_Inlined (Defining_Entity (N)); - - -- Establish the linkages between the spec and the body. These are - -- used when the expression function acts as the prefix of attribute - -- 'Access in order to freeze the original expression which has been - -- moved to the generated body. - - Set_Corresponding_Body (N, Defining_Entity (New_Body)); - Set_Corresponding_Spec (New_Body, Defining_Entity (N)); - -- To prevent premature freeze action, insert the new body at the end -- of the current declarations, or at the end of the package spec. -- However, resolve usage names now, to prevent spurious visibility @@ -716,7 +715,7 @@ package body Sem_Ch6 is -- the enclosing instance is analyzed. if GNATprove_Mode - and then Is_Generic_Actual_Subprogram (Defining_Entity (N)) + and then Is_Generic_Actual_Subprogram (Def_Id) then Insert_After (N, New_Body); @@ -735,16 +734,13 @@ package body Sem_Ch6 is -- instance, where this has been done during generic analysis, -- and will be redone when analyzing the body. - Set_Parent (Expr, Ret); - Push_Scope (Def_Id); - Install_Formals (Def_Id); - if not In_Instance then + Push_Scope (Def_Id); + Install_Formals (Def_Id); Preanalyze_Spec_Expression (Expr, Typ); Check_Limited_Return (Original_Node (N), Expr, Typ); + End_Scope; end if; - - End_Scope; end if; end; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0dc5f08d88b..1f4eb1b8fdb 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -29,64 +29,65 @@ -- to complete the syntax checks. Certain pragmas are handled partially or -- completely by the parser (see Par.Prag for further details). -with Aspects; use Aspects; -with Atree; use Atree; -with Casing; use Casing; -with Checks; use Checks; -with Contracts; use Contracts; -with Csets; use Csets; -with Debug; use Debug; -with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; -with Exp_Dist; use Exp_Dist; -with Exp_Util; use Exp_Util; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Gnatvsn; use Gnatvsn; -with Lib; use Lib; -with Lib.Writ; use Lib.Writ; -with Lib.Xref; use Lib.Xref; -with Namet.Sp; use Namet.Sp; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Output; use Output; -with Par_SCO; use Par_SCO; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch12; use Sem_Ch12; -with Sem_Ch13; use Sem_Ch13; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Elim; use Sem_Elim; -with Sem_Eval; use Sem_Eval; -with Sem_Intr; use Sem_Intr; -with Sem_Mech; use Sem_Mech; -with Sem_Res; use Sem_Res; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Sinfo.CN; use Sinfo.CN; -with Sinput; use Sinput; -with Stringt; use Stringt; -with Stylesw; use Stylesw; +with Aspects; use Aspects; +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Contracts; use Contracts; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Dist; use Exp_Dist; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Gnatvsn; use Gnatvsn; +with Lib; use Lib; +with Lib.Writ; use Lib.Writ; +with Lib.Xref; use Lib.Xref; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Output; use Output; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Intr; use Sem_Intr; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Stringt; use Stringt; +with Stylesw; use Stylesw; +with System.Case_Util; with Table; -with Targparm; use Targparm; -with Tbuild; use Tbuild; +with Targparm; use Targparm; +with Tbuild; use Tbuild; with Ttypes; -with Uintp; use Uintp; -with Uname; use Uname; -with Urealp; use Urealp; -with Validsw; use Validsw; -with Warnsw; use Warnsw; +with Uintp; use Uintp; +with Uname; use Uname; +with Urealp; use Urealp; +with Validsw; use Validsw; +with Warnsw; use Warnsw; package body Sem_Prag is @@ -17923,24 +17924,24 @@ package body Sem_Prag is Name_Increases) then declare - Name : constant String := + Name : String := Get_Name_String (Chars (Variant)); begin -- It is a common mistake to write "Increasing" for -- "Increases" or "Decreasing" for "Decreases". Recognize - -- specially names starting with "Incr" or "Decr" to + -- specially names starting with "incr" or "decr" to -- suggest the corresponding name. + System.Case_Util.To_Lower (Name); + if Name'Length >= 4 - and then (Name (1 .. 4) = "Incr" - or else Name (1 .. 4) = "incr") + and then Name (1 .. 4) = "incr" then Error_Pragma_Arg_Ident ("expect name `Increases`", Variant); elsif Name'Length >= 4 - and then (Name (1 .. 4) = "Decr" - or else Name (1 .. 4) = "decr") + and then Name (1 .. 4) = "decr" then Error_Pragma_Arg_Ident ("expect name `Decreases`", Variant); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b03926b37ec..a399be05f17 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -23173,4 +23173,6 @@ package body Sem_Util is end if; end Yields_Universal_Type; +begin + Errout.Current_Subprogram_Ptr := Current_Subprogram'Access; end Sem_Util;