+2017-09-08 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb: Use System.Case_Util.To_Lower to simplify code.
+
+2017-09-08 Arnaud Charlet <charlet@adacore.com>
+
+ * 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 <jaloyan@adacore.com>
+
+ * 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 <miranda@adacore.com>
+
+ * 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 <ebotcazou@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Reorder some
+ statements, use local variable and remove unnecessary processing.
+
2017-09-08 Javier Miranda <miranda@adacore.com>
* exp_ch6.ads (Make_Build_In_Place_Iface_Call_In_Allocator): New
-- 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)
-- 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.
-- 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
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.
-- 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;
-- 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;
-- --
-- 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- --
-- 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 --
-----------------------------------
-- 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
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))))
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)
-- 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
-- --
-- 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- --
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 --
-------------
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 --
----------
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;
-- --
-- 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- --
-- GNAT.HTable to keep as much coherency as possible between these two
-- related units.
-private with Ada.Finalization;
-
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
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.
-- 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;
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;
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.
-- 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
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
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
-- 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);
-- 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;
-- 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
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);
end if;
end Yields_Universal_Type;
+begin
+ Errout.Current_Subprogram_Ptr := Current_Subprogram'Access;
end Sem_Util;
projects / gcc.git / commitdiff